Объединение книг Excel, но нужно все листы, а не только первый

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 на 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