汇总求助(有点难度），请大神出手帮助

细雨言寺

汇总求助(有点难度），请大神出手帮助

iwangyi

Sub CC()
Set D = CreateObject("SCRIPTING.DICTIONARY")
Set dd = CreateObject("SCRIPTING.DICTIONARY")
P = ThisWorkbook.Path & "\"
F = Dir(P & "\" & "*.XL*")
Do While F <> ""
If F <> ThisWorkbook.Name Then
Set WB = Workbooks.Open(P & F)
arr = Sheets("学生成绩理科").UsedRange
For i = 4 To UBound(arr)
D(arr(i, 2)) = Array(arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 6))
dd(arr(i, 2) & arr(2, 7)) = arr(i, 7)
Next
WB.Close
End If
F = Dir
Loop
Stop
N = [A65536].End(3).Row
For rn = 2 To N
Cells(rn, 3).Resize(, 4) = D(Cells(rn, 2).Value)
For y = 7 To 17 Step 2
Cells(rn, y) = dd(Cells(rn, 2) & Cells(1, y))
Next
Next
End Sub

iwangyi

附件，请参考************

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Dim wb As Workbook
   
6.   Dim ws As Worksheet
   
7.   Dim mypath$, myname$
   
8.   Application.ScreenUpdating = False
   
9.   Application.DisplayAlerts = False
   
10.   Set d = CreateObject("scripting.dictionary")
    
11.   mypath = ThisWorkbook.Path & ""
    
12.   With Worksheets("sheet1")
    
13.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
14.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
15.     .Range("c2").Resize(r - 1, c - 2).ClearContents
    
16.     arr = .Range("a1").Resize(r, c)
    
17.   End With
    
18.   For i = 2 To UBound(arr)
    
19.     d(CStr(arr(i, 2))) = i
    
20.   Next
    
21.   For j = 7 To UBound(arr, 2)
    
22.     If Dir(mypath & arr(1, j) & "成绩.xls") <> "" Then
    
23.       Set wb = GetObject(mypath & arr(1, j) & "成绩.xls")
    
24.       With wb
    
25.         With .Worksheets(1)
    
26.           r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
27.           brr = .Range("a4:q" & r)
    
28.           For i = 1 To UBound(brr)
    
29.             If d.exists(CStr(brr(i, 2))) Then
    
30.               m = d(CStr(brr(i, 2)))
    
31.               If j = 7 Then
    
32.                 For k = 3 To 6
    
33.                   arr(m, k) = brr(i, k)
    
34.                 Next
    
35.               End If
    
36.               arr(m, j) = brr(i, 7)
    
37.             End If
    
38.           Next
    
39.         End With
    
40.         .Close False
    
41.       End With
    
42.     End If
    
43.   Next
    
44.   For j = 7 To UBound(arr, 2) Step 2
    
45.     d.RemoveAll
    
46.     For i = 2 To UBound(arr)
    
47.       If Len(arr(i, j)) <> 0 Then
    
48.         d(arr(i, j)) = d(arr(i, j)) + 1
    
49.       End If
    
50.     Next
    
51.     nn = 1
    
52.     kk = d.keys
    
53.     For k = 0 To UBound(kk)
    
54.       mm = Application.Large(kk, k + 1)
    
55.       ss = d(mm)
    
56.       d(mm) = nn
    
57.       nn = nn + ss
    
58.     Next
    
59.     For i = 2 To UBound(arr)
    
60.       If Len(arr(i, j)) <> 0 Then
    
61.         arr(i, j + 1) = d(arr(i, j))
    
62.       End If
    
63.     Next
    
64.   Next
    
65.   With Worksheets("sheet1")
    
66.     .Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
67.     For i = 2 To UBound(arr)
    
68.       For j = 7 To UBound(arr, 2)
    
69.         If Len(arr(i, j)) = 0 Then
    
70.           With .Cells(i, j)
    
71.             .Value = "缺考"
    
72.             .Interior.ColorIndex = 6
    
73.           End With
    
74.         End If
    
75.       Next
    
76.     Next
    
77.   End With
    
78. End Sub
    

复制代码

chxw68

详见附件。

微笑12345

chxw68 发表于 2018-9-5 18:41
详见附件。

已拜读，太牛了

细雨言寺

chxw68 发表于 2018-9-5 18:41
详见附件。

感谢，测试成功了。谢谢您。