Question

我有一个代码，通过该代码，我可以选择工作簿并将其复制到单个工作簿中。但问题是我能够将所有工作簿的sheet1复制到我的摘要工作簿的sheet1，但我想将所有工作簿中的所有工作表复制到我的目标工作簿。请注意，所有工作簿上的工作表名称都相同。

以下是我的代码。

Private Sub Merge_All_Click()

    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
    Dim LastRow As Long


    ' 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 = "C:\Users\ivan.emmanuel\Desktop\My Macro"

    ' 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)

        ' Set the cell in column A to be the file name.
        SummarySheet.Range("A" & NRow).Value = FileName

        ' Set the source range to be A9 through C9.
        ' Modify this range for your workbooks. It can span multiple rows.
        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:E" & LastRow)


        ' Set the destination range to start at column B and be the same size as the source range.
        Set DestRange = SummarySheet.Range("B" & 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

为了实现这一点，必须循环工作簿中的所有工作表。

ANS：

             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
        Dim LastRow As Long
        Sub merge()


        ' 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 = "C:\Users\ivan.emmanuel\Desktop\My Macro"

        ' 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)

            ' Set the cell in column A to be the file name.
            SummarySheet.Range("A" & NRow).Value = FileName

            ' Set the source range to be A9 through C9.
            ' Modify this range for your workbooks. It can span multiple rows.
            LastRow = WorkBk.Worksheets(1).Cells.Find(What:="*", _
                     After:=WorkBk.Worksheets(1).Cells.Range("A1"), _
                     SearchDirection:=xlPrevious, _
                     LookIn:=xlFormulas, _
                     SearchOrder:=xlByRows).Row
         Dim ws As Worksheet                        '---------added to for copy from all worksheets
         For Each ws In Workbook                    '--------

             Set SourceRange = ws.Range("A1:E" & LastRow)  '------------


            ' Set the destination range to start at column B and be the same size as the source range.
            Set DestRange = SummarySheet.Range("B" & 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

        Next                                     '------------
            ' 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 个答案: