Question

我发现这个VBA代码适用于在一个文件夹中组合工作簿，但是，我需要修改它以便每个工作簿中的所有工作表都被复制/粘贴而不仅仅是每个工作表的第一个工作表工作簿。截至目前，只复制了每个选定工作簿中的第一个工作表。我在哪里可以插入代码来查找所有工作表中的数据？

谢谢！

Sub MergeSelectedWorkbooks()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim SelectedFiles() As Variant
Dim NRow As Long
Dim FileName As String
Dim NFile As Long
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range

' Create a new workbook and set a variable to the first sheet.
Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)

' Modify this folder path to point to the files you want to use.
FolderPath = "S:\example"

' Set the current directory to the the folder path.
ChDrive FolderPath
ChDir FolderPath

' Open the file dialog box and filter on Excel files, allowing multiple files
' to be selected.
SelectedFiles = Application.GetOpenFilename( _
    filefilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)

' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 1

' Loop through the list of returned file names
For NFile = LBound(SelectedFiles) To UBound(SelectedFiles)
    ' Set FileName to be the current workbook file name to open.
    FileName = SelectedFiles(NFile)

    ' Open the current workbook.
    Set WorkBk = Workbooks.Open(FileName)

Dim LastRow As Long
LastRow = WorkBk.Worksheets(1).Cells.Find(What:="*", _
             After:=WorkBk.Worksheets(1).Cells.Range("A1"), _
             SearchDirection:=xlPrevious, _
             LookIn:=xlFormulas, _
             SearchOrder:=xlByRows).Row
Set SourceRange = WorkBk.Worksheets(1).Range("A1:Z" & LastRow)

    ' Set the destination range to start at column A and be the same size as the source range.
    Set DestRange = SummarySheet.Range("A" & NRow)
    Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
       SourceRange.Columns.Count)

    ' Copy over the values from the source to the destination.
    DestRange.Value = SourceRange.Value

    ' Increase NRow so that we know where to copy data next.
    NRow = NRow + DestRange.Rows.Count

    ' Close the source workbook without saving changes.
    WorkBk.Close savechanges:=False
Next NFile

' Call AutoFit on the destination sheet so that all data is readable.
SummarySheet.Columns.AutoFit
End Sub

Answer 1

打开多个工作簿（1 x 1），将所有工作表中的数据复制到一个工作表中。确保修改适合您的范围（复制范围当前为A2到Z（最后一行）。

Option Explicit

Sub MoveSheets()


Dim IndvFiles As FileDialog
Dim Currentbook As Workbook
Dim x As Integer
Dim i As Integer
Dim CurrentSheets As Integer
Dim BookCount As Integer

'Opens File Dialog to Select Which Files You Want to Consolidate
    Set IndvFiles = Application.FileDialog(msoFileDialogOpen)
    With IndvFiles
        .AllowMultiSelect = True
        .Title = "Multi-select target data files:"
        .ButtonName = ""
        .Filters.Clear
        .Show
    End With


Application.ScreenUpdating = False
Application.DisplayAlerts = False

CurrentSheets = ThisWorkbook.Worksheets.Count
BookCount = IndvFiles.SelectedItems.Count
Dim LROW as Long
DIM LROW2 as Long
DIM Import as Range

        For x = 1 To BookCount
            On Error GoTo StopHere:

            Set Currentbook = Workbooks.Open(IndvFiles.SelectedItems(X))

                For i = 1 To Currentbook.Worksheets.Count
                    LROW = thisworkbook.sheets("desired sheet name paste").Range("A2").End(XLdown).Rows
                    LROW2=currentbook.sheets(i).Range("A2").End(XLdown).Rows
                         Set Import = currentbook.sheets(i).Range("A2:Z"&LROW2)
                         Import.Copy
                              ThisWorkbook.Sheets("Desired sheet name paste range").Range("A"&LROW).PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
                Next i
                Currentbook.Close False
        Next x

StopHere:
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

结合Excel工作簿，但需要所有工作表，而不仅仅是第一个

1 个答案: