小白求助！分类排名及排名输出，恳请大侠出手，提前祝大家新春快乐，万事如意！

uuuuu516

小白求助！分类排名及排名输出word文档，恳请大侠出手，提前祝大家新春快乐，万事如意！

1、成绩表格中的班级排名可否用公式得出。

2、排名输入word文档，样式


，，

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   Set d1 = CreateObject("scripting.dictionary")
   
7.   With Worksheets("sheet1")
   
8.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.     c = .Cells(4, .Columns.Count).End(xlToLeft).Column
   
10.     arr = .Range("a5").Resize(r - 4, c)
    
11.     For j = 4 To UBound(arr, 2) Step 3
    
12.       d.RemoveAll
    
13.       d1.RemoveAll
    
14.       For i = 1 To UBound(arr)
    
15.         If Len(arr(i, j)) <> 0 Then
    
16.           If Not d.exists(arr(i, 2)) Then
    
17.             Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
    
18.           End If
    
19.           d(arr(i, 2))(arr(i, j)) = d(arr(i, 2))(arr(i, j)) + 1
    
20.           d1(arr(i, j)) = d1(arr(i, j)) + 1
    
21.         End If
    
22.       Next
    
23.       For Each aa In d.keys
    
24.         nn = 1
    
25.         kk = d(aa).keys
    
26.         For k = 0 To UBound(kk)
    
27.           mm = Application.Large(kk, k + 1)
    
28.           ss = d(aa)(mm)
    
29.           d(aa)(mm) = nn
    
30.           nn = nn + ss
    
31.         Next
    
32.       Next
    
33.       nn = 1
    
34.       kk = d1.keys
    
35.       For k = 0 To UBound(kk)
    
36.         mm = Application.Large(kk, k + 1)
    
37.         ss = d1(mm)
    
38.         d1(mm) = nn
    
39.         nn = nn + ss
    
40.       Next
    
41.       For i = 1 To UBound(arr)
    
42.         If Len(arr(i, j)) <> 0 Then
    
43.           arr(i, j + 1) = d(arr(i, 2))(arr(i, j))
    
44.           arr(i, j + 2) = d1(arr(i, j))
    
45.         End If
    
46.       Next
    
47.     Next
    
48.     .Range("a5").Resize(UBound(arr), UBound(arr, 2)) = arr
    
49.   End With
    
50. End Sub
    

复制代码

chxw68

添加了班级排名和年级排名的代码。

cqcbc

chxw68 发表于 2020-1-22 09:54
添加了班级排名和年级排名的代码。

不错，收藏了。

uuuuu516

感谢大侠

uuuuu516

chxw68 发表于 2020-1-22 09:54
添加了班级排名和年级排名的代码。

感谢

凌空一羽

今天整个上午在弄Excel数据导入到Word中
http://club.excelhome.net/thread-1519086-1-1.html
(出处: ExcelHome技术论坛)
你要的导入word文档

uuuuu516

凌空一羽 发表于 2020-1-22 14:10
今天整个上午在弄Excel数据导入到Word中
http://club.excelhome.net/thread-1519086-1-1.html
(出处: Exc ...

感谢老师，祝新春快乐！

chxw68

1. Sub test2()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   Set d1 = CreateObject("scripting.dictionary")
   
7.   Dim wordapp As Word.Application
   
8.   Dim worddoc As Word.Document
   
9.   With Worksheets("sheet1")
   
10.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.     c = .Cells(4, .Columns.Count).End(xlToLeft).Column
    
12.     arr = .Range("a3").Resize(r - 2, c)
    
13.   End With
    
14.   For j = 4 To UBound(arr, 2) Step 3
    
15.     Set d(arr(1, j)) = CreateObject("scripting.dictionary")
    
16.     nh3 = Application.Large(Application.Index(arr, 0, j + 2), 3)
    
17.     d1.RemoveAll
    
18.     For i = 3 To UBound(arr)
    
19.       If Len(arr(i, j)) <> 0 Then
    
20.         If Not d1.Exists(arr(i, 2)) Then
    
21.           m = 1
    
22.           ReDim brr(1 To m)
    
23.         Else
    
24.           brr = d1(arr(i, 2))
    
25.           m = UBound(brr) + 1
    
26.           ReDim Preserve brr(1 To m)
    
27.         End If
    
28.         brr(m) = arr(i, j + 1)
    
29.         d1(arr(i, 2)) = brr
    
30.       End If
    
31.     Next
    
32.     For Each aa In d1.keys
    
33.       brr = d1(aa)
    
34.       bh3 = Application.Large(brr, 3)
    
35.       d1(aa) = bh3
    
36.     Next
    
37.     For w = 1 To 2
    
38.       For i = 3 To UBound(arr)
    
39.         If Len(arr(i, j)) <> 0 Then
    
40.           If w = 1 Then
    
41.             xm = arr(i, 2)
    
42.           Else
    
43.             xm = 0
    
44.           End If
    
45.           If Not d(arr(1, j)).Exists(xm) Then
    
46.             Set d(arr(1, j))(xm) = CreateObject("scripting.dictionary")
    
47.           End If
    
48.           q = 0
    
49.           If arr(i, j + w) <= 3 Then
    
50.             q = 1
    
51.           ElseIf arr(i, j + w) >= IIf(w = 1, d1(arr(i, 2)), nh3) Then
    
52.             q = 2
    
53.           End If
    
54.           If q <> 0 Then
    
55.             If Not d(arr(1, j))(xm).Exists(q) Then
    
56.               m = 1
    
57.               ReDim brr(1 To 5, 1 To m)
    
58.             Else
    
59.               brr = d(arr(1, j))(xm)(q)
    
60.               m = UBound(brr, 2) + 1
    
61.               ReDim Preserve brr(1 To 5, 1 To m)
    
62.             End If
    
63.             brr(1, m) = arr(i, 1)
    
64.             brr(2, m) = arr(i, 2)
    
65.             brr(3, m) = arr(i, 3)
    
66.             brr(4, m) = arr(i, j)
    
67.             brr(5, m) = arr(i, j + w)
    
68.             d(arr(1, j))(xm)(q) = brr
    
69.           End If
    
70.         End If
    
71.       Next
    
72.     Next
    
73.   Next
    
74.   For Each aa In d.keys
    
75.     For Each bb In d(aa).keys
    
76.       For Each cc In d(aa)(bb).keys
    
77.         brr = d(aa)(bb)(cc)
    
78.         For i = 1 To UBound(brr, 2) - 1
    
79.           p = i
    
80.           For j = i + 1 To UBound(brr, 2)
    
81.             If IIf(cc = 1, brr(5, p) > brr(5, j), brr(5, p) < brr(5, j)) Then
    
82.               p = j
    
83.             End If
    
84.           Next
    
85.           If p <> i Then
    
86.             For k = 1 To UBound(brr)
    
87.               temp = brr(k, i)
    
88.               brr(k, i) = brr(k, p)
    
89.               brr(k, p) = temp
    
90.             Next
    
91.           End If
    
92.         Next
    
93.         d(aa)(bb)(cc) = brr
    
94.       Next
    
95.     Next
    
96.   Next
    
97.   Set wordapp = New Word.Application
    
98.   wordapp.Visible = True
    
99.   Set worddoc = wordapp.Documents.Add
    
100.   worddoc.Select
     
101. 
     
102.   With wordapp.Selection
     
103.     For Each aa In d.keys
     
104.       With .Font
     
105.         .Name = "黑体"
     
106.         .Size = 20
     
107.       End With
     
108.       .ParagraphFormat.Alignment = wdAlignParagraphCenter
     
109.       .ParagraphFormat.CharacterUnitFirstLineIndent = 0
     
110.       .ParagraphFormat.FirstLineIndent = CentimetersToPoints(0)
     
111.       .TypeText Text:=aa & "排名"
     
112.       .TypeParagraph
     
113.       With .Font
     
114.         .Name = "宋体"
     
115.         .Size = 16
     
116.       End With
     
117.       .Font.Bold = True
     
118.       .ParagraphFormat.Alignment = wdAlignParagraphLeft
     
119.       .TypeText Text:="一、年级排名"
     
120.       .Font.Bold = False
     
121.       .TypeParagraph
     
122.       .ParagraphFormat.Alignment = wdAlignParagraphJustify
     
123.       .ParagraphFormat.CharacterUnitFirstLineIndent = 2
     
124.       brr = d(aa)(0)(1)
     
125.       ss = ""
     
126.       For j = 1 To UBound(brr, 2)
     
127.         ss = ss & "第" & brr(5, j) & "名是" & brr(2, j) & brr(1, j) & "，学籍号是" & brr(3, j) & "，成绩是" & brr(4, j) & "分；"
     
128.       Next
     
129.       .TypeText Text:=ss
     
130.       .TypeParagraph
     
131.       brr = d(aa)(0)(2)
     
132.       ss = "后三名是"
     
133.       For j = 1 To UBound(brr, 2)
     
134.         ss = ss & brr(2, j) & brr(1, j) & "，学籍号是" & brr(3, j) & "，成绩是" & brr(4, j) & "分；"
     
135.       Next
     
136.       .TypeText Text:=ss
     
137.       .TypeParagraph
     
138. '      .ParagraphFormat.Alignment = wdAlignParagraphLeft
     
139.       .ParagraphFormat.Alignment = wdAlignParagraphJustify
     
140.       .ParagraphFormat.CharacterUnitFirstLineIndent = 0
     
141.       .ParagraphFormat.FirstLineIndent = CentimetersToPoints(0)
     
142.       .Font.Bold = True
     
143.       .TypeText Text:="二、班级排名"
     
144.       .Font.Bold = False
     
145.       .TypeParagraph
     
146.       For Each bb In Array("一班", "二班", "三班")
     
147.         If d(aa).Exists(bb) Then
     
148.           .ParagraphFormat.Alignment = wdAlignParagraphCenter
     
149. '          .ParagraphFormat.Alignment = wdAlignParagraphJustify
     
150.           .ParagraphFormat.CharacterUnitFirstLineIndent = 0
     
151.           .ParagraphFormat.FirstLineIndent = CentimetersToPoints(0)
     
152.           .Font.Bold = True
     
153.           .TypeText Text:=bb
     
154.           .Font.Bold = False
     
155.           .TypeParagraph
     
156.           .ParagraphFormat.Alignment = wdAlignParagraphLeft
     
157.           brr = d(aa)(bb)(1)
     
158.           ss = ""
     
159.           For j = 1 To UBound(brr, 2)
     
160.             ss = ss & "第" & brr(5, j) & "名是" & brr(2, j) & brr(1, j) & "，学籍号是" & brr(3, j) & "，成绩是" & brr(4, j) & "分；"
     
161.           Next
     
162.           .ParagraphFormat.Alignment = wdAlignParagraphJustify
     
163.           .ParagraphFormat.CharacterUnitFirstLineIndent = 2
     
164.           .TypeText Text:=ss
     
165.           .TypeParagraph
     
166.           brr = d(aa)(bb)(2)
     
167.           ss = "后三名是"
     
168.           For j = 1 To UBound(brr, 2)
     
169.             ss = ss & brr(2, j) & brr(1, j) & "，学籍号是" & brr(3, j) & "，成绩是" & brr(4, j) & "分；"
     
170.           Next
     
171.           .TypeText Text:=ss
     
172.           .TypeParagraph
     
173.         End If
     
174.       Next
     
175.     Next
     
176.   End With
     
177.   worddoc.SaveAs ThisWorkbook.Path & "\排名.doc"
     
178. '  wordapp.Quit
     
179. '  Set wordapp = Nothing
     
180. '  Set worddoc = Nothing
     
181.   Application.DisplayAlerts = True
     
182. End Sub
     

复制代码

chxw68

详见附件。