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

我发现这个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

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

---

您知道如何为…下一个循环编写

。您是否尝试过制作一个参数化硬编码
（1）的循环
？谢谢，但我正在尝试将所有选定工作簿中所有工作表中的所有数据粘贴到一张工作表中，而不是将一个工作簿粘贴到多张工作表中。上述代码已被修改。请确保重新命名将粘贴所有数据的工作表，并在需要时修改范围（当然，这两项代码都有更改）。您可能还需要在此中添加一些内容，以取消隐藏列/行，并删除任何给定工作表中存在的筛选器。我在以下行中遇到语法错误：
ThisWorkbook.Sheets（“所需工作表名称粘贴范围”）.range（“a”&LROW）.Paste特殊粘贴：=xlPasteValues，操作：=xlNone，skipblanks uu2; Next i
我对VBA不是很有经验，因此提前感谢您。请确定要粘贴所有数据的工作表的名称。在上一行，交换“所需的工作表名称粘贴范围”工作表的实际名称。工作表名称必须用引号括起来。@Andrew代码是否符合您的要求？如果是，请点击回答旁边的复选框：）如果不是，请告诉我问题所在
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