Excle多簿同表数据汇总，多簿同表数据合成一簿多表（小狼独家分享）

多簿同表数据汇总：Option Explicit 

Option Explicit
Sub 汇总2()
     Dim i%, j%, f$, k%, n%, m%
     Dim wb As Workbook, sht As Worksheet
     Dim d As Object, s
     Dim arr, arr1()
     Set d = CreateObject("scripting.dictionary")

      s = Timer
      f = Dir(ThisWorkbook.Path & "\*.xlsx")
      Application.ScreenUpdating = False
      Application.DisplayAlerts = False
      Do While f <> ""
               Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f)
               For Each sht In Worksheets
                         sht.Activate
                         i = [a100000].End(3).Row

                         arr = Range("A2:D" & i)
                         For k = 1 To UBound(arr)
                         If Not d.exists(arr(k, 1) & arr(k, 2) & arr(k, 3)) Then
                              n = n + 1
                              d(arr(k, 1) & arr(k, 2) & arr(k, 3)) = n
                              ReDim Preserve arr1(1 To 4, 1 To n) '必须重新定义数组的维度
                              arr1(1, n) = arr(k, 1)
                              arr1(2, n) = arr(k, 2)
                              arr1(3, n) = arr(k, 3)
                              arr1(4, n) = arr(k, 4)
                         Else
                              m = d(arr(k, 1) & arr(k, 2) & arr(k, 3))
                              arr1(4, m) = arr1(4, m) + arr(k, 4)
                         End If
                         Next k
                         Erase arr

               Next sht
               wb.Close False
     f = Dir
     Loop
              Range("A2").Resize(d.Count, 4) = Application.Transpose(arr1)
              Range("A1:D1") = Array("需求", "单号", "日期", "进度")

              ActiveWorkbook.Worksheets("后台").Sort.SortFields.Clear
              ActiveWorkbook.Worksheets("后台").Sort.SortFields.Add Key:=Range("A8"), _
              SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
              With ActiveWorkbook.Worksheets("后台").Sort
                  .SetRange Range("A2:D10")
                  .Header = xlNo
                  .MatchCase = False
                  .Orientation = xlTopToBottom
                  .SortMethod = xlPinYin
                  .Apply
               End With
              MsgBox "汇总报表用时" & s - Timer & "秒"

End Sub

 多簿同表数据合成一簿多表：

Sub 多文件多表合并()
    Dim sPath As String '接收要合并的文件夹路径
    
    '-----------选择要合并的文件件-----------------
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "请选择要合并的文件夹"
        .InitialFileName = ThisWorkbook.Path
        .AllowMultiSelect = False
        If .Show Then
            sPath = .SelectedItems(1)
        End If
    End With
    
    '-----------遍历合并--------------------------------
    Dim wb As Workbook, ws As Worksheet
    Dim fileCount As Integer, maxRow As Integer
    Dim iRow As Integer, iCol As Integer
    Dim sFile As String
    
    Set ws = ThisWorkbook.Sheets(1)
    Dim sht As Worksheet
    
    '清空历史内容，防重复
    ws.Cells.ClearContents
    Application.ScreenUpdating = False
    If sPath <> "" Then
        sPath = sPath & "\"
        sFile = Dir(sPath & "*.xlsx")
        Do While Len(sFile) > 0
            Set wb = Workbooks.Open(sPath & sFile)
            For Each sht In wb.Sheets
                fileCount = fileCount + 1
                '复制到同一个工作薄
                sht.Copy after:=ws
            Next
            wb.Close 0
            sFile = Dir
        Loop
    End If
    Application.ScreenUpdating = True
    MsgBox "合并完成,共合并" & fileCount & "个工作表", vbOKOnly, "提示"
End Sub