VBA 合并文件夹中的工作簿

Question

我需要将一个文件夹中的所有工作簿合并到一个文件中，我正在寻找的规范是我的文件夹是动态的，所以我需要一个用于代码的文件夹选择器。接下来文件夹中的每个工作簿都有多个工作表，我只需要合并具有名称（“报告”）的工作表。数据也从范围（“A7”）开始。它还包含各个表格中的公式，因此组合后不应出现公式错误。

有人可以帮忙吗？

Sub GetWorkbook()

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False

Path = ThisWorkbook.Path & "\"
Filename = Dir(Path & "*.xlsx")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
ActiveSheet.AutoFilterMode = False
Sheets("Report").Copy After:=ThisWorkbook.Sheets(1)
Range("1:6").EntireRow.Hidden = True
Workbooks(Filename).Close
Filename = Dir()
Loop
Application.DisplayAlerts = True
Combine
Sheets("Home").Select
MsgBox ("Data Consolidated"), vbInformation

End Sub


Function combine
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Combined" And ws.Name <> "Home" Then
ws.Activate
Dim LastRowW As Long
LastRowW = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Range("A7:P" & LastRowW).Copy 
Sheets("Combined").Select
Range("A1048576").End(xlUp).Offset(1, 0).Select
ActiveCell.PasteSpecial (xlPasteValues)
ws.Delete
End If
Next ws

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True

End Function

这是代码，我在宏工作簿中主要有 2 个工作表（组合和家庭）。第二个功能是将详细信息复制到组合工作表并删除其他工作簿。仅当所有工作簿都保存在（此工作簿路径）中时，这才有效。如何启用文件夹选择器来合并所选文件夹中的文件。

Answer 1

考虑这个选项。有四个基本示例，此页面上的 3 个和示例工作簿中的 4 个： 1）合并文件夹中所有工作簿的范围（彼此下方） 2）从您选择的每个工作簿中合并一个范围（彼此下方） 3）合并文件夹中所有工作簿的范围（彼此相邻） 4) 使用 AutoFilter 合并文件夹中所有工作簿的范围

Sub Basic_Example_1()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long

'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron\test"

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
    MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
    MsgBox "No files found"
    Exit Sub
End If

'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
    Fnum = Fnum + 1
    ReDim Preserve MyFiles(1 To Fnum)
    MyFiles(Fnum) = FilesInPath
    FilesInPath = Dir()
Loop

'Change ScreenUpdating, Calculation and EnableEvents
With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
End With

'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
    For Fnum = LBound(MyFiles) To UBound(MyFiles)
        Set mybook = Nothing
        On Error Resume Next
        Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
        On Error GoTo 0

        If Not mybook Is Nothing Then

            On Error Resume Next

            With mybook.Worksheets(1)
                Set sourceRange = .Range("A1:C1")
            End With

            If Err.Number > 0 Then
                Err.Clear
                Set sourceRange = Nothing
            Else
                'if SourceRange use all columns then skip this file
                If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                    Set sourceRange = Nothing
                End If
            End If
            On Error GoTo 0

            If Not sourceRange Is Nothing Then

                SourceRcount = sourceRange.Rows.Count

                If rnum + SourceRcount >= BaseWks.Rows.Count Then
                    MsgBox "Sorry there are not enough rows in the sheet"
                    BaseWks.Columns.AutoFit
                    mybook.Close savechanges:=False
                    GoTo ExitTheSub
                Else

                    'Copy the file name in column A
                    With sourceRange
                        BaseWks.cells(rnum, "A"). _
                                Resize(.Rows.Count).Value = MyFiles(Fnum)
                    End With

                    'Set the destrange
                    Set destrange = BaseWks.Range("B" & rnum)

                    'we copy the values from the sourceRange to the destrange
                    With sourceRange
                        Set destrange = destrange. _
                                        Resize(.Rows.Count, .Columns.Count)
                    End With
                    destrange.Value = sourceRange.Value

                    rnum = rnum + SourceRcount
                End If
            End If
            mybook.Close savechanges:=False
        End If

    Next Fnum
    BaseWks.Columns.AutoFit
End If

退出TheSub： '恢复 ScreenUpdating、Calculation 和 EnableEvents 有应用程序 .ScreenUpdating = True .EnableEvents = 真 .Calculation = CalcMode 结束于 结束子

https://www.rondebruin.nl/win/s3/win008.htm

作为替代方案，我强烈推荐此插件。

https://www.rondebruin.nl/win/addins/rdbmerge.htm