Question

我需要将文件夹中的所有工作簿合并到一个文件中，我看的规格是我的文件夹是动态的，所以我需要一个文件夹选择器来代码。接下来，文件夹中的每个工作簿都有多个工作表，我只需要合并名称（“报表”）的工作表。数据也从Range（“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

这是代码，我在宏工作簿（组合和home）中主要有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为Long，Fnum为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

ExitTheSub：＆＃39;恢复ScreenUpdating，Calculation和EnableEvents 随着应用 .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode 结束结束子

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

作为替代方案，我强烈推荐这个AddIn。

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

VBA将工作簿合并到一个文件夹中

1 个答案: