请教多工作簿合并汇总问题！

longyi999

各位江湖大佬，请援手抽空帮我解决下我的多工作簿合并汇总问题，本人初入江湖能力有限，望侠士们拔刀相助，万分感谢！！

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.14  排重汇总
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set sh = ThisWorkbook.Sheets("2024奖金发放汇总")
   
7.     Set d = CreateObject("Scripting.Dictionary")
   
8.     a = [{"1月","2月","3月","4月","5月","6月","7月","8月","9月","10月","11月","年终奖"}]
   
9.     ReDim brr(1 To 10000, 1 To 100)
   
10.     Dim tm: tm = Timer
    
11.     p = ThisWorkbook.Path & ""
    
12.     On Error Resume Next
    
13.     For Each f In fso.GetFolder(p).Files
    
14.         If LCase$(f.Name) Like "*.xls*" Then
    
15.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
16.                 fn = fso.GetBaseName(f)
    
17.                 st = Replace(fn, "份奖金发放表", "")
    
18.                 yf = Mid(st, 8)
    
19.                 Set wb = Workbooks.Open(f, 0)
    
20.                 With wb.Sheets(1)
    
21.                     r = .Cells(Rows.Count, 1).End(3).Row
    
22.                     c = .UsedRange.Columns.Count
    
23.                     arr = .[a1].Resize(r, c)
    
24.                     wb.Close False
    
25.                 End With
    
26.                 For i = 4 To UBound(arr)
    
27.                     s = arr(i, 2)
    
28.                     If s <> Empty Then
    
29.                         If Not d.exists(s) Then
    
30.                             m = m + 1
    
31.                             d(s) = m
    
32.                             brr(m, 1) = m
    
33.                             brr(m, 2) = s
    
34.                         End If
    
35.                         r = d(arr(i, 2))
    
36.                         n = 2
    
37.                         For x = 1 To UBound(a)
    
38.                             If yf = a(x) Then
    
39.                                 n = n + x
    
40.                                 Exit For
    
41.                             End If
    
42.                         Next
    
43.                         brr(r, n) = brr(r, n) + arr(i, 4)
    
44.                     End If
    
45.                 Next
    
46.             End If
    
47.         End If
    
48.     Next f
    
49.     With sh
    
50.         .UsedRange.Offset(2).Clear
    
51.         .[a2].Resize(1, 15).Interior.Color = 49407
    
52.         With .[a3].Resize(m, 15)
    
53.             .Value = brr
    
54.             .Borders.LineStyle = 1
    
55.             .HorizontalAlignment = xlCenter
    
56.             .VerticalAlignment = xlCenter
    
57.         End With
    
58.         For i = 3 To m + 2
    
59.             .Cells(i, 15) = Application.Sum(.Cells(i, 3).Resize(, 13))
    
60.         Next
    
61.     End With
    
62.     Set d = Nothing
    
63.     Application.ScreenUpdating = True
    
64.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
65. End Sub
    

复制代码

limonet

关键字：union all+pivot

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Path$, Filename$
    Range("A:F").ClearContents
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    Path = ThisWorkbook.Path & "\"
    Filename = Dir(Path & "*.xlsx")
    Do While Filename <> ""
        StrSQL = StrSQL & " Union All Select *," & Split(Split(Filename, "月")(0), "年")(1) & " as Mon From [Excel 12.0;DataBase=" & Path & Filename & "].[Sheet1$B3:C] Where 姓名<>''"
        Filename = Dir
    Loop
    StrSQL = "TransForm Sum(应发金额) Select 姓名 From (" & Mid(StrSQL, 12) & ") Group By 姓名 Pivot Mon"
    Set Rst = Cn.Execute(StrSQL)
    For j = 0 To Rst.Fields.Count - 1
        Cells(1, j + 1) = Rst.Fields(j).Name
    Next j
    Range("A2").CopyFromRecordset Rst
End Sub

Qs18

ub qs()
    Dim fso As Object, dic As Object
    Dim folderPath As String
    Dim file As Object
    Dim wb As Workbook, xb As Workbook
Set wb = ThisWorkbook
brr = Sheet1.Range("a2:o" & Sheet1.Range("b2").End(xlDown).Row)
Set dic = CreateObject("scripting.dictionary")
ph = ThisWorkbook.Path
    ' 创建FileSystemObject对象
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    ' 设置要遍历的文件夹路径
    folderPath = ph
    ' 检查文件夹是否存在
    If fso.FolderExists(folderPath) Then
        ' 获取文件夹
        Set folder = fso.GetFolder(folderPath)
        ' 遍历文件夹中的所有文件
        For Each file In folder.Files
            ' 检查文件是否是Excel文件
            If LCase(fso.GetExtensionName(file.Name)) = "xlsx" Or _
               LCase(fso.GetExtensionName(file.Name)) = "xls" Then
                ' 这里是文件名
                Debug.Print file.Name
                Set xb = Workbooks.Open(ph & "\" & file.Name, 0)
                arr = xb.Sheets(1).Range("a2").CurrentRegion.Value
                xb.Close (0)
                    For i = 4 To UBound(arr)
                        If arr(i, 2) <> "" Then
                            dic(arr(i, 2)) = arr(i, 4)
                        End If
                    Next
                  For b = 3 To UBound(brr, 2)
                    If InStr(file.Name, brr(1, b)) Then
                        cl = b
                        Exit For
                    End If
                  Next
                For x = 2 To UBound(brr)
                    If brr(x, 2) <> Empty Then
                    brr(x, b) = dic(brr(x, 2))
                    brr(x, UBound(brr, 2)) = brr(x, UBound(brr, 2)) + brr(x, b)
                    End If
                Next
               
            End If
            dic.RemoveAll
        Next file
    Else
        MsgBox "指定的文件夹不存在。"
    End If
    Sheet1.Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    ' 清理
    Set fso = Nothing: Set wb = Nothing
    Set folder = Nothing: Set xb = Nothing: Set dic = Nothing
    Application.ScreenUpdating = True
End Sub

Qs18

试试..........

Qs18

试试.........