如何根据关键列班级和姓名汇总各工作簿工作表数据

yzyyyyyyy

汇总表：关键列，班级，姓名，以班级+姓名为关键列，汇总各工作簿学科分数。              各工作簿工作表中无关键字记录，或分数为空白，写入问题工作表。
多个工作簿多个工作表：关键列，班级，姓名，以班级+姓名为关键列；
工作簿名为学科名；
以工作簿即学科，以班级+姓名为关键字，汇总各工作表分数（最后一列）相加即分数的和。 如何根据关键列班级和姓名汇总各工作簿工作表数据20210118.rar (7.47 KB, 下载次数: 10)

2022-1-18 16:40 上传

点击文件名下载附件

cai2532

关注并学习

chxw68

1. Sub test()
   
2.   Dim r%, i%, n(1 To 3) As Byte
   
3.   Dim arr, brr, crr(1 To 10000, 1 To 10)
   
4.   Dim mypath$, myname$
   
5.   Dim wb As Workbook
   
6.   Dim ws As Worksheet
   
7.   Dim d As Object
   
8.   Application.ScreenUpdating = False
   
9.   Application.DisplayAlerts = False
   
10.   Set d = CreateObject("scripting.dictionary")
    
11.   Set d1 = CreateObject("scripting.dictionary")
    
12.   With Worksheets("汇总")
    
13.     r = .Cells(.Rows.Count, 2).End(xlUp).Row
    
14.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
15.     .Range("g2").Resize(r - 1, c - 6).ClearContents
    
16.     brr = .Range("a1").Resize(r, c)
    
17.     For i = 2 To UBound(brr)
    
18.       xm = brr(i, 2) & "+" & brr(i, 4)
    
19.       d(xm) = i
    
20.       For j = 7 To UBound(brr, 2)
    
21.         Set brr(i, j) = CreateObject("scripting.dictionary")
    
22.       Next
    
23.     Next
    
24.   End With
    
25.   x = 0
    
26.   For j = 7 To UBound(brr, 2)
    
27.     If Dir(ThisWorkbook.Path & "" & brr(1, j) & ".xls") <> "" Then
    
28.       Set wb = GetObject(ThisWorkbook.Path & "" & brr(1, j) & ".xls")
    
29.       With wb
    
30.         For Each ws In .Worksheets
    
31.           With ws
    
32.             If Not d1.exists(brr(1, j)) Then
    
33.               Set d1(brr(1, j)) = CreateObject("scripting.dictionary")
    
34.             End If
    
35.             d1(brr(1, j))(ws.Name) = Empty
    
36.             r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
37.             c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
38.             arr = .Range("a1").Resize(r, c)
    
39.             Erase n
    
40.             For k = 1 To UBound(arr, 2)
    
41.               If arr(1, k) = "班级" Then
    
42.                 n(1) = k
    
43.               ElseIf arr(1, k) = "姓名" Then
    
44.                 n(2) = k
    
45.               ElseIf arr(1, k) = "分数" Then
    
46.                 n(3) = k
    
47.               End If
    
48.             Next
    
49.             If n(1) * n(2) * n(3) <> 0 Then
    
50.               For i = 2 To UBound(arr)
    
51.                 xm = arr(i, n(1)) & "+" & arr(i, n(2))
    
52.                 If d.exists(xm) Then
    
53.                   m = d(xm)
    
54.                   brr(m, j)(ws.Name) = arr(i, n(3))
    
55.                     x = x + 1
    
56.                     crr(x, 1) = x
    
57.                     crr(x, 2) = Empty
    
58.                     crr(x, 3) = arr(i, n(1))
    
59.                     crr(x, 4) = Empty
    
60.                     crr(x, 5) = arr(i, n(2))
    
61.                     crr(x, 8) = brr(1, j)
    
62.                     crr(x, 9) = ws.Name
    
63.                     crr(x, 10) = "分数空白"
    
64.                 End If
    
65.               Next
    
66.             End If
    
67.           End With
    
68.         Next
    
69.         .Close False
    
70.       End With
    
71.     End If
    
72.   Next
    
73.   x = 0
    
74.   For j = 7 To UBound(brr, 2)
    
75.     For i = 2 To UBound(brr)
    
76.       If d1.exists(brr(1, j)) Then
    
77.         ss = 0
    
78.         For Each bb In d1(brr(1, j)).keys
    
79.           If brr(i, j).exists(bb) Then
    
80.             If brr(i, j)(bb) <> Empty Then
    
81.               ss = ss + brr(i, j)(bb)
    
82.             Else
    
83.               x = x + 1
    
84.               crr(x, 1) = x
    
85.               crr(x, 2) = Empty
    
86.               crr(x, 3) = brr(i, 2)
    
87.               crr(x, 4) = Empty
    
88.               crr(x, 5) = brr(i, 4)
    
89.               crr(x, 8) = brr(1, j)
    
90.               crr(x, 9) = bb
    
91.               crr(x, 10) = "分数空白"
    
92.             End If
    
93.           Else
    
94.             x = x + 1
    
95.             crr(x, 1) = x
    
96.             crr(x, 2) = Empty
    
97.             crr(x, 3) = brr(i, 2)
    
98.             crr(x, 4) = Empty
    
99.             crr(x, 5) = brr(i, 4)
    
100.             crr(x, 8) = brr(1, j)
     
101.             crr(x, 9) = bb
     
102.             crr(x, 10) = "无记录"
     
103.           End If
     
104.         Next
     
105.         brr(i, j) = ss
     
106.       Else
     
107.         brr(i, j) = Empty
     
108.       End If
     
109.     Next
     
110.   Next
     
111.   With Worksheets("汇总")
     
112.     .Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
     
113.   End With
     
114.   With Worksheets("问题")
     
115.     .UsedRange.Offset(1, 0).Clear
     
116.     If x > 0 Then
     
117.       .Range("a2").Resize(x, UBound(crr, 2)) = crr
     
118.     End If
     
119.   End With
     
120. End Sub
     

复制代码

chxw68

详见附件。

cui26896

审核中，请参考附件
汇总.zip (17.74 KB, 下载次数: 15)

2022-1-19 17:36 上传

点击文件名下载附件

cui26896

1. Sub test()
   
2.     Dim cnn As Object, rs As Object, SQL$, s$, MyPath$, MyFile$
   
3.     Dim ar, br, i&, j&, d As Object, lname$, Sn$, CRS$
   
4.     Application.ScreenUpdating = False
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     With ThisWorkbook.Sheets("汇总")
   
7.       .Range("g2:o" & .Cells(Rows.Count, 2).End(xlUp).Row).ClearContents
   
8.       ar = .[G1:O1 & ""]
   
9.     End With
   
10.     ReDim br(1 To 2, 1 To UBound(ar))
    
11.     For j = 1 To UBound(ar)
    
12.       br(1, j) = ar(j)
    
13.       br(2, j) = j + 6
    
14.     Next
    
15.     MyPath = ThisWorkbook.Path & ""
    
16.     MyFile = Dir(MyPath & "*.xls*")
    
17.     Do While MyFile <> ""
    
18.       If InStr(MyFile, ThisWorkbook.Name) = 0 Then
    
19.         Set cnn = CreateObject("ADODB.Connection")
    
20.         cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=yes';Data Source=" & MyPath & MyFile
    
21.         Set rs = cnn.OpenSchema(20)
    
22.         Do Until rs.EOF
    
23.           If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
24.             lname = Replace(rs("TABLE_NAME").Value, "'", "")
    
25.             If Right(lname, 1) = "$" Then
    
26.               CRS = Replace(MyFile, ".xls", "")
    
27.               Sn = Replace(lname, "$", "")
    
28.               SQL = "select 班级,姓名,分数 from [" & lname & "]"
    
29.               d(SQL) = ""
    
30.             End If
    
31.           End If
    
32.           rs.MoveNext
    
33.         Loop
    
34.         SQL = Join(d.keys, " UNION ALL ")
    
35.         SQL = "select 姓名,sum(分数) as 分数 from (" & SQL & ") group by 姓名,班级"
    
36.         SQL = "select b.分数 from [Excel 12.0;Database=" & ThisWorkbook.FullName & "].[汇总$]a left join (" & SQL & ")b on b.姓名=a.姓名"
    
37.         For j = 1 To UBound(br, 2)
    
38.           If CRS = br(1, j) Then
    
39.             With ThisWorkbook.Sheets("汇总")
    
40.               .Activate
    
41.               .Cells(2, br(2, j)).CopyFromRecordset cnn.Execute(SQL)
    
42.             End With
    
43.           End If
    
44.         Next
    
45.         cnn.Close
    
46.         Set cnn = Nothing
    
47.       End If
    
48.     MyFile = Dir()
    
49.     Loop
    
50. End Sub

复制代码

cai2532

cui26896 发表于 2022-1-19 17:37

拜读学习了