將多個工作簿的行復制到一個主工作簿中

Question

我想打開一個僅包含一張紙的工作簿，
將數據復制到AC列，直到A列中的最后一個可用行，
將數據粘貼到工作簿“ Mergedsheet.xlsx”中A列的第一個空行中。

我想遍歷特定文件夾中存在的所有工作簿，但是會遇到很多錯誤。

Sub MergeNew()
    Dim WorkBk As Workbook
    Dim MergedSheet As Worksheet
    Dim SourceData As Range
    Dim DestinationData As Range
    Dim lastRow As Long
    Dim NextRow As Range
    Dim FolderPath As String
    Dim FileNames As String 

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    FolderPath = "E:\Jan to March 2019\Bharuch 31\"
    FileNames = Dir(FolderPath & "*.xls*")
    Do While FileNames <> ""
        Set WorkBk = Workbooks.Open(FolderPath & FileNames)
        Range("A1:AC1").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        Workbooks.Open Filename:="E:\Jan to March 2019\Bharuch 31\MergedSheet.xlsx"
        lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
        Range("A" & lastRow).Select
        ActiveSheet.Paste
        'ActiveWindow.Close SaveChanges:=True
        'ActiveWindow.Close SaveChanges:=False
        Application.CutCopyMode = False

        FileNames = Dir()
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Answer 1

您正在遍歷一個文件夾，並將每個工作簿的第一張工作表的數據復制粘貼到工作簿A。但是，工作簿A也位於該文件夾中。 因此（循環時）您應該小心跳過它。

（或者，您可以為DIR函數提供一個不同的參數（例如，如果可能的話，一些通配符條件排除工作簿A），因此您不必經常檢查循環內部。）

未經測試。

Option Explicit

Private Sub MergeNew()
    'Application.ScreenUpdating = False 'Uncomment this when you know code is working.
    'Application.DisplayAlerts = False 'Uncomment this when you know code is working.

    Dim folderPath As String
    folderPath = GetFolderPath(titleToShow:="Select the folder containing the files to loop through.")

    Dim Filename As String
    Filename = Dir$(folderPath & "*.xls*")

    If Len(Filename) = 0 Then
        MsgBox "Could not find a relevant file in '" & folderPath & "'. Code will stop running now."
        Exit Sub ' No point in carrying on in such a case.
    End If

    Dim destinationFolderPath As String
    destinationFolderPath = GetFolderPath(titleToShow:="Select the folder to save the 'MergedSheet.xlsx' file to.")

    Dim destinationWorkbook As Workbook
    Set destinationWorkbook = Application.Workbooks.Add

    ' This line may throw an error
    destinationWorkbook.SaveAs Filename:=destinationFolderPath & "MergedSheet.xlsx", FileFormat:=xlOpenXMLWorkbook

    Dim destinationSheet As Worksheet
    Set destinationSheet = destinationWorkbook.Worksheets(1) ' I assume there's only 1 sheet in there, but change as necessary.

    Do Until Len(Filename) = 0
        Dim fullFilePathToOpen As String
        fullFilePathToOpen = folderPath & Filename

        If fullFilePathToOpen <> destinationWorkbook.FullName Then ' Probably could have just compared filename since directory is the same, but this is more explicit
            Dim sourceWorkbook As Workbook
            Set sourceWorkbook = Application.Workbooks.Open(Filename:=fullFilePathToOpen, ReadOnly:=True) ' If you don't make changes to the workbook you open, better to open as read-only

            Dim sourceSheet As Worksheet
            Set sourceSheet = sourceWorkbook.Worksheets(1) ' You say there's only one worksheet in there, so referring by index should be okay (for now)

            Dim lastSourceRow As Long
            lastSourceRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row ' Assume last row can be determined from column A alone

            Dim lastDestinationRow As Long
            lastDestinationRow = destinationSheet.Cells(destinationSheet.Rows.Count, "A").End(xlUp).Row + 1

            If destinationSheet.Rows.Count < (lastDestinationRow + lastSourceRow) Then
                MsgBox "Ran out of rows (in sheet '" & sourceSheet.Name & "' of workbook '" & destinationWorkbook.Name & "')"
                Exit Sub
            End If

            sourceSheet.Range("A1", sourceSheet.Cells(lastSourceRow, "AC")).Copy Destination:=destinationSheet.Cells(lastDestinationRow, "A")

            sourceWorkbook.Close False
        End If
        Filename = Dir$()
    Loop

    'Application.ScreenUpdating = True 'Uncomment this when you know code is working.
    'Application.DisplayAlerts = True 'Uncomment this when you know code is working.
End Sub

Private Function GetFolderPath(Optional ByVal titleToShow As String = vbNullString) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If Len(titleToShow) > 0 Then .Title = titleToShow
        .AllowMultiSelect = False ' Only one is allowed.
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "Folder selection appears to have cancelled. Code will stop running now"
            End
        End If
        GetFolderPath = .SelectedItems(1) & "\"
    End With
End Function