[已解决]VBA将每位学生的成绩数据汇总表一张表（汇总当前文件夹下所有工作薄中指定工作表数...

yjwdjfqb

VBA将每位学生的成绩数据汇总表一张表（汇总当前文件夹下所有工作薄中指定工作表数据到一张表）

将　所有工作薄（除汇总表）的成绩工作表中的数据，汇总到　汇总工作薄的汇总工作表。

请老师们帮帮忙，谢谢大家了！

VBA将每位学生的成绩数据汇总表一张表（汇总当前文件夹下所有工作薄中指定工作表数据到.rar (7.46 KB, 下载次数: 43)

2015-1-18 16:32 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

xdragon

2015-1-18 17:06

1. Sub total()
   
2.     Dim fn$, pth$, data, i&, j%, re(), n&
   
3.     Dim wb As Workbook
   
4.     Dim dx As Object, dy As Object
   
5.     pth = ThisWorkbook.Path & ""
   
6.     fn = Dir(pth & "*.xls")
   
7.     ReDim re(1 To 20000, 1 To 3)
   
8.     Set dx = CreateObject("scripting.dictionary")
   
9.     Set dy = CreateObject("scripting.dictionary")
   
10.     Do Until fn = ""
    
11.         If fn <> ThisWorkbook.Name Then
    
12.             Set wb = GetObject(pth & fn)
    
13.             With wb.Sheets(1)
    
14.                 If Application.CountA(.UsedRange) > 0 Then
    
15.                     data = .UsedRange.Value
    
16.                     For j = 4 To UBound(data, 2)
    
17.                         If Not dy.exists(data(1, j)) Then dy(data(1, j)) = dy.Count + 1: ReDim Preserve re(1 To UBound(re), 1 To dy.Count + 2)
    
18.                         For i = 2 To UBound(data)
    
19.                             If Not dx.exists(data(i, 2) & data(i, 3)) Then
    
20.                                 n = dx.Count + 1
    
21.                                 dx(data(i, 2) & data(i, 3)) = n
    
22.                                 re(n + 1, 1) = data(i, 2)
    
23.                                 re(n + 1, 2) = data(i, 3)
    
24.                             End If
    
25.                             re(dx(data(i, 2) & data(i, 3)) + 1, dy(data(1, j)) + 2) = data(i, j)
    
26.                         Next
    
27.                     Next
    
28.                 End If
    
29.             End With
    
30.             wb.Close 0
    
31.             Set wb = Nothing
    
32.         End If
    
33.         fn = Dir
    
34.     Loop
    
35.     data = dy.keys
    
36.     re(1, 1) = "姓名": re(1, 2) = "班级"
    
37.     For i = 0 To UBound(data)
    
38.         re(1, i + 3) = data(i)
    
39.     Next
    
40.     Range("A1").Resize(dx.Count + 1, UBound(re, 2)) = re
    
41. End Sub

复制代码

跳转到最佳答案楼层

xdragon

1. Sub total()
   
2.     Dim fn$, pth$, data, i&, j%, re(), n&
   
3.     Dim wb As Workbook
   
4.     Dim dx As Object, dy As Object
   
5.     pth = ThisWorkbook.Path & ""
   
6.     fn = Dir(pth & "*.xls")
   
7.     ReDim re(1 To 20000, 1 To 3)
   
8.     Set dx = CreateObject("scripting.dictionary")
   
9.     Set dy = CreateObject("scripting.dictionary")
   
10.     Do Until fn = ""
    
11.         If fn <> ThisWorkbook.Name Then
    
12.             Set wb = GetObject(pth & fn)
    
13.             With wb.Sheets(1)
    
14.                 If Application.CountA(.UsedRange) > 0 Then
    
15.                     data = .UsedRange.Value
    
16.                     For j = 4 To UBound(data, 2)
    
17.                         If Not dy.exists(data(1, j)) Then dy(data(1, j)) = dy.Count + 1: ReDim Preserve re(1 To UBound(re), 1 To dy.Count + 2)
    
18.                         For i = 2 To UBound(data)
    
19.                             If Not dx.exists(data(i, 2) & data(i, 3)) Then
    
20.                                 n = dx.Count + 1
    
21.                                 dx(data(i, 2) & data(i, 3)) = n
    
22.                                 re(n + 1, 1) = data(i, 2)
    
23.                                 re(n + 1, 2) = data(i, 3)
    
24.                             End If
    
25.                             re(dx(data(i, 2) & data(i, 3)) + 1, dy(data(1, j)) + 2) = data(i, j)
    
26.                         Next
    
27.                     Next
    
28.                 End If
    
29.             End With
    
30.             wb.Close 0
    
31.             Set wb = Nothing
    
32.         End If
    
33.         fn = Dir
    
34.     Loop
    
35.     data = dy.keys
    
36.     re(1, 1) = "姓名": re(1, 2) = "班级"
    
37.     For i = 0 To UBound(data)
    
38.         re(1, i + 3) = data(i)
    
39.     Next
    
40.     Range("A1").Resize(dx.Count + 1, UBound(re, 2)) = re
    
41. End Sub

复制代码

dsmch

1. Sub Macro1()
   
2. Dim arr(1 To 60000, 1 To 6), brr, d
   
3. Dim mypath, wj, j%, s&, i&, zf
   
4. Set d = CreateObject("scripting.dictionary")
   
5. mypath = ThisWorkbook.Path & ""
   
6. Application.ScreenUpdating = False
   
7. For j = 1 To 6
   
8.     d(Cells(1, j).Value) = j
   
9. Next
   
10. wj = Dir(mypath & "*.xls")
    
11. Do While wj <> ""
    
12.     If wj <> ThisWorkbook.Name Then
    
13.         With GetObject(mypath & wj)
    
14.             brr = .Sheets(1).Range("a1").CurrentRegion
    
15.             .Close 0
    
16.         End With
    
17.         For i = 2 To UBound(brr)
    
18.             zf = brr(i, 2) & "," & brr(i, 3)
    
19.             If Not d.exists(zf) Then s = s + 1: d(zf) = s
    
20.             h = d(zf)
    
21.             For j = 2 To UBound(brr, 2)
    
22.                 arr(h, d(brr(1, j))) = brr(i, j)
    
23.             Next
    
24.         Next
    
25.     End If
    
26.     wj = Dir
    
27. Loop
    
28. Range("a2").Resize(s, UBound(arr, 2)) = arr
    
29. Application.ScreenUpdating = True
    
30. End Sub

复制代码

yjwdjfqb

xdragon 发表于 2015-1-18 17:06

老师你们，能帮我加下注释吗，谢谢老师了！

xdragon 发表于 2015-1-18 17:06

大师你好~我想请教下这个反过来要怎么做？就是把一张表里的汇集数据填到单独的多张表？谢谢！