工作簿中的工作表汇总

cysczhumh

工作簿中有3个以上的考勤表，每个考勤表中的人员不同，数量不同，在表中的顺序也不同。要求汇总成表4的格式，采用字典和数组编制VBA代码，代码要进行优化。

Deepseek汇总2个表可以，3个表及以上时，代码就有很多错误。

gwjkkkkk

Option Explicit
Sub test2()
    Dim ar, br, i&, j&, r&, dic As Object, wks As Worksheet, iPosRow&
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    With Worksheets(4)
        r = .Cells(.Rows.Count, "A").End(xlUp).Row
        With .Range("A2:E" & r)
            .Offset(1).Clear
            ar = .Resize(10 ^ 4).Value: r = 1
            For Each wks In Worksheets
                If Val(wks.Name) Then
                    br = wks.[A1].CurrentRegion.Value
                    For i = 3 To UBound(br)
                        If Not dic.exists(br(i, 1)) Then
                            r = r + 1: ar(r, 1) = br(i, 1)
                            dic(br(i, 1)) = r
                        End If
                        iPosRow = dic(br(i, 1))
                        For j = 2 To UBound(ar, 2)
                            ar(iPosRow, j) = ar(iPosRow, j) + br(i, j)
                        Next j
                    Next i
                End If
            Next
        End With
        If r Then
            With .[A2].Resize(r, UBound(ar, 2))
                .Value = ar
            End With
        End If
        .Activate
    End With

    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

代码审核中。。。

shiruiqiang

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    t = Timer
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("汇总表")
    Set d = CreateObject("scripting.dictionary")
    ReDim crr(1 To 10000, 1 To 100)
    n = 1: m = 1
    For Each sh In wb.Sheets
        If sh.Name <> "汇总表" Then
            With sh
                brr = .UsedRange
            End With
            For i = 3 To UBound(brr)
                If brr(i, 1) <> Empty Then
                    If Not d.exists(brr(i, 1)) And brr(i, 1) <> Empty Then
                        n = n + 1
                        d(brr(i, 1)) = n
                        crr(n, 1) = brr(i, 1)
                    End If
                    y = d(brr(i, 1))
                    For j = 2 To UBound(brr, 2)
                        If Not d.exists(brr(2, j)) Then
                            m = m + 1
                            d(brr(2, j)) = m
                            crr(1, m) = brr(2, j)
                        End If
                        x = d(brr(2, j))
                        crr(y, x) = crr(y, x) + brr(i, j)
                    Next
                End If
            Next
        End If
    Next
    Set d = Nothing
    With sht
        .[A2].CurrentRegion.Clear
        .[A2].Resize(n, m) = crr
        .[A2] = "姓名"
        .[A2].CurrentRegion.Borders.LineStyle = 1
        .[A2].CurrentRegion.HorizontalAlignment = xlCenter
        .[A2].CurrentRegion.Columns.AutoFit
        .[a1] = "汇总表"
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "共耗时：" & Format(Timer - t, "0.0000") & " 秒！！！", 64
End Sub
   
   
   
   
   

ykcbf1100

比较简单，附件供参考。。。

ykcbf1100

1. Sub ykcbf()    '//2025.4.2
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set Sh = ThisWorkbook.Sheets("考勤汇总")
   
5.     ReDim brr(1 To 10 ^ 5, 1 To 100)
   
6.     For Each sht In Sheets
   
7.         If sht.Name <> Sh.Name Then
   
8.             arr = sht.UsedRange
   
9.             For i = 3 To UBound(arr)
   
10.                 s = arr(i, 1)
    
11.                 If s = Empty Then Exit For
    
12.                 If Not d.exists(s) Then
    
13.                     m = m + 1
    
14.                     d(s) = m
    
15.                     For j = 1 To UBound(arr, 2)
    
16.                         brr(m, j) = arr(i, j)
    
17.                     Next
    
18.                 Else
    
19.                     r = d(s)
    
20.                     For j = 2 To UBound(arr, 2)
    
21.                         brr(r, j) = brr(r, j) + arr(i, j)
    
22.                     Next
    
23.                 End If
    
24.             Next
    
25.         End If
    
26.     Next
    
27.     With Sh
    
28.         .UsedRange.Offset(2) = Empty
    
29.         .[a3].Resize(m, UBound(arr, 2)) = brr
    
30.         .[a3].Resize(m, UBound(arr, 2)).Borders.LineStyle = 1
    
31.     End With
    
32.     Set d = Nothing
    
33.     Application.ScreenUpdating = True
    
34.     MsgBox "OK！"
    
35. End Sub
    

复制代码

cysczhumh

gwjkkkkk 发表于 2025-4-1 21:26
代码审核中。。。

非常谢谢，程序运行正确。有点小遗憾，如果再添加表4，表5，...，表12，汇总全年的数据时，程序就不能运行了。

cysczhumh

quqiyuan 发表于 2025-4-1 22:26
参与一下，仅供参考。。。

非常感谢，完全符合我的要求，是个万能程序。