vba如何把不同的成绩汇总到一张表里？

ykcbf1100

附件请参考。。。

ykcbf1100

代码如下，请参考。。。

1. Sub 汇总()  '//2023.3.23
   
2.     Dim arr, brr, d
   
3.     Dim tm: tm = Timer
   
4.     p = ThisWorkbook.Path & ""
   
5.     f = Dir(p & "*.xls*")
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     Set sh = Sheet1
   
9.     b = sh.[a1:i1]
   
10.     Set d = CreateObject("Scripting.Dictionary")
    
11.     Set d1 = CreateObject("Scripting.Dictionary")
    
12.     Do While f <> ""
    
13.         If f <> ThisWorkbook.Name Then
    
14.             n = n + 1
    
15.             Set wb = GetObject(p & f)
    
16.             Set sht = wb.Sheets(1)
    
17.             arr = sht.UsedRange
    
18.             wb.Close False
    
19.             For i = 2 To UBound(arr)
    
20.                 s = arr(i, 3)
    
21.                 d(s) = arr(i, 2)
    
22.                 s1 = arr(i, 3) & "|" & arr(1, 4)
    
23.                 d1(s1) = arr(i, 4)
    
24.             Next
    
25.         End If
    
26.         f = Dir
    
27.     Loop
    
28.     ReDim brr(1 To d.Count, 1 To 10)
    
29.     For Each k In d.keys
    
30.         m = m + 1
    
31.         brr(m, 1) = m
    
32.         brr(m, 2) = d(k)
    
33.         brr(m, 3) = k
    
34.     Next
    
35.     With sh
    
36.         .UsedRange.Offset(1).Clear
    
37.         .[a2].Resize(m, 3) = brr
    
38.         Set Rng = .[a1].Resize(m + 1, 9)
    
39.         arr = Rng.Value
    
40.         For i = 2 To UBound(arr)
    
41.             For j = 4 To UBound(arr, 2)
    
42.                 s = arr(i, 3) & "|" & arr(1, j)
    
43.                 If d1.exists(s) Then
    
44.                     arr(i, j) = d1(s)
    
45.                 End If
    
46.             Next
    
47.         Next
    
48.         With Rng
    
49.             .Value = arr
    
50.             .Borders.LineStyle = 1
    
51.             .VerticalAlignment = xlCenter
    
52.             .HorizontalAlignment = xlCenter
    
53.         End With
    
54.     End With
    
55.     Application.ScreenUpdating = True
    
56.     MsgBox "汇总完毕，共用时：" & Format(Timer - tm, "0.00") & "秒"
    
57. End Sub
    

复制代码

shiruiqiang

lwz2019 发表于 2023-3-23 11:51
新问题附件在9楼，我试着改了一下，成绩总是提不出来？

新附件没变动，你修改一下标识的地方就行

lwz2019

成绩汇总.zip (34.19 KB, 下载次数: 13)

2023-3-23 13:35 上传

点击文件名下载附件

lwz2019

shiruiqiang 发表于 2023-3-23 13:18
新附件没变动，你修改一下标识的地方就行

发错了，新发的在13楼但是按照你的我改了还是不行？

咩咩咩2012

flag,研究下

fzxba

13F附件_参与.rar (34.69 KB, 下载次数: 23)

2023-3-23 14:06 上传

点击文件名下载附件

sxbjzjf110

参与一下。。。。。。

shiruiqiang

lwz2019 发表于 2023-3-23 13:36
发错了，新发的在13楼但是按照你的我改了还是不行？

字段没统一

lwz2019

shiruiqiang 发表于 2023-3-23 14:10
字段没统一

明白了，问题不是您说那样，是我把后面y=4也改了，所以出不了成绩