VBA多表格分类汇总——绩效考核（数组版）

295672500

1. Sub 合并()
   
2. ThisWorkbook.Save
   
3. t = Timer
   
4. Dim a As Byte, arr2(1 To 300, 1 To 7)
   
5. b = Sheets("汇总").Cells(Rows.Count, 2).End(xlUp).Row
   
6. If b - 2 <> 0 Then
   
7. Sheets("汇总").[b3].Resize(b - 2, 7).ClearContents
   
8.    End If
   
9. arr = [{"高线", "棒线", "机加"}]
   
10. For Each w In arr
    
11. a = Sheets(w).Cells(Rows.Count, 2).End(xlUp).Row
    
12.   arr1 = Sheets(w).Range("b3:h" & a)
    
13. For i = 1 To a - 2
    
14.   For j = 1 To UBound(arr2)
    
15.   If "'" & arr1(i, 1) = arr2(j, 1) Then
    
16.       arr2(j, 3) = arr2(j, 3) & arr1(i, 3)
    
17.       arr2(j, 4) = arr2(j, 4) + arr1(i, 4)
    
18.       arr2(j, 5) = arr2(j, 5) & arr1(i, 5)
    
19.       arr2(j, 6) = arr2(j, 6) + arr1(i, 6)
    
20.       arr2(j, 7) = arr2(j, 7) + arr1(i, 7)
    
21.     GoTo 100
    
22.         End If
    
23.     Next j
    
24.      k = k + 1
    
25.         arr2(k, 1) = "'" & arr1(i, 1)
    
26.         arr2(k, 2) = arr1(i, 2)
    
27.         arr2(k, 3) = arr1(i, 3)
    
28.         arr2(k, 4) = arr1(i, 4)
    
29.         arr2(k, 5) = arr1(i, 5)
    
30.         arr2(k, 6) = arr1(i, 6)
    
31.         arr2(k, 7) = arr1(i, 7)
    
32. 100:
    
33. Next
    
34. Sheets("汇总").[b3].Resize(k, 7) = arr2
    
35. Next
    
36. MsgBox Format(Timer - t, "0.0000")
    
37. End Sub

复制代码

蓝桥玄霜

合并的例子：

295672500

蓝桥玄霜 发表于 2020-11-27 17:41
合并的例子：

谢谢您百忙之中，帮我指正不足之处。
您有所不知，我的分表可能会有重复的内容，需要分类汇总，因此您写的代码只适合将各个分表堆叠起来，不适合分类汇总

1. Sub 合并改进()
   
2. ThisWorkbook.Save
   
3. t = Timer
   
4. Dim arr2()
   
5. For Each sh In Sheets
   
6. If sh.Name <> "汇总" Then
   
7. arr1 = sh.Range("b3:h" & sh.UsedRange.Rows.Count)
   
8. arr = Application.Transpose(arr1)
   
9. act = act + UBound(arr1)
   
10. ReDim Preserve arr2(1 To 7, 1 To act)
    
11. bb = sh.UsedRange.Rows.Count
    
12.    For i = 1 To bb - 2
    
13.     For j = 1 To act
    
14.      If "'" & arr(1, i) = arr2(1, j) Then
    
15.       arr2(3, j) = arr2(3, j) & arr(3, i)
    
16.       arr2(4, j) = arr2(4, j) + arr(4, i)
    
17.       arr2(5, j) = arr2(5, j) & arr(5, i)
    
18.       arr2(6, j) = arr2(6, j) + arr(6, i)
    
19.       arr2(7, j) = arr2(7, j) + arr(7, i)
    
20.      GoTo 100
    
21.     End If
    
22.     Next j
    
23.     k = k + 1
    
24.         arr2(1, k) = "'" & arr(1, i)
    
25.         arr2(2, k) = arr(2, i)
    
26.         arr2(3, k) = arr(3, i)
    
27.         arr2(4, k) = arr(4, i)
    
28.         arr2(5, k) = arr(5, i)
    
29.         arr2(6, k) = arr(6, i)
    
30.         arr2(7, k) = arr(7, i)
    
31. 100:
    
32.    Next i
    
33. End If
    
34. Next sh
    
35. Sheets("汇总").[b3].Resize(k, 7) = Application.Transpose(arr2)
    
36. MsgBox Format(Timer - t, "0.0000")
    
37. End Sub

复制代码

295672500

再次改进

1. Sub 合并改进()
   
2. ThisWorkbook.Save
   
3. t = Timer
   
4. Dim arr2()
   
5. For Each sh In Sheets
   
6. If sh.Name <> "汇总" Then
   
7. arr = sh.Range("b3:h" & sh.UsedRange.Rows.Count)
   
8. act = act + UBound(arr)
   
9. ReDim Preserve arr2(1 To 7, 1 To act)
   
10. bb = sh.UsedRange.Rows.Count
    
11.    For i = 1 To bb - 2
    
12.     For j = 1 To act
    
13.      If "'" & arr(i, 1) = arr2(1, j) Then
    
14.       arr2(3, j) = arr2(3, j) & arr(i, 3)
    
15.       arr2(4, j) = arr2(4, j) + arr(i, 4)
    
16.       arr2(5, j) = arr2(5, j) & arr(i, 5)
    
17.       arr2(6, j) = arr2(6, j) + arr(i, 6)
    
18.       arr2(7, j) = arr2(7, j) + arr(i, 7)
    
19.      GoTo 100
    
20.     End If
    
21.     Next j
    
22.     k = k + 1
    
23.         arr2(1, k) = "'" & arr(i, 1)
    
24.         arr2(2, k) = arr(i, 2)
    
25.         arr2(3, k) = arr(i, 3)
    
26.         arr2(4, k) = arr(i, 4)
    
27.         arr2(5, k) = arr(i, 5)
    
28.         arr2(6, k) = arr(i, 6)
    
29.         arr2(7, k) = arr(i, 7)
    
30. 100:
    
31.    Next i
    
32. End If
    
33. Next sh
    
34. Sheets("汇总").[b3].Resize(k, 7) = Application.Transpose(arr2)
    
35. MsgBox Format(Timer - t, "0.0000")
    
36. End Sub

复制代码

295672500

字典和数组结合

1. Sub 多列合并计算()
   
2. ThisWorkbook.Save
   
3. t = Timer                            '计时开始
   
4. Application.ScreenUpdating = False   '禁止屏幕刷新
   
5. Dim arr2()
   
6. Set d = CreateObject("scripting.dictionary")
   
7. For Each sh In Sheets
   
8. If sh.Name <> "汇总" Then
   
9.   arr = sh.Range("b3:h" & sh.Cells(Rows.Count, 2).End(xlUp).Row)
   
10.   For i = 1 To UBound(arr)
    
11.      If Not d.exists(arr(i, 1)) Then
    
12.        n = n + 1
    
13.        d(arr(i, 1)) = n
    
14.        ReDim Preserve arr2(1 To 7, 1 To n)
    
15.         arr2(1, n) = "'" & arr(i, 1)
    
16.         arr2(2, n) = arr(i, 2)
    
17.         arr2(3, n) = arr(i, 3)
    
18.         arr2(4, n) = arr(i, 4)
    
19.         arr2(5, n) = arr(i, 5)
    
20.         arr2(6, n) = arr(i, 6)
    
21.         arr2(7, n) = arr(i, 7)
    
22.       Else
    
23.         m = d(arr(i, 1))
    
24.         arr2(3, m) = arr2(3, m) & arr(i, 3)
    
25.         arr2(4, m) = arr2(4, m) + arr(i, 4)
    
26.         arr2(5, m) = arr2(5, m) & arr(i, 5)
    
27.         arr2(6, m) = arr2(6, m) + arr(i, 6)
    
28.         arr2(7, m) = arr2(7, m) + arr(i, 7)
    
29.      End If
    
30.         Next i
    
31. End If
    
32. Next sh
    
33. Sheets("汇总").[b3].Resize(n, 7) = Application.Transpose(arr2)
    
34. Application.ScreenUpdating = True    '开启屏幕刷新
    
35. MsgBox Format(Timer - t, "汇总完成，耗时：0.00000秒" & Chr(10) & "作者：刘磊") '计时结束
    
36. End Sub

复制代码