excel - 将多行工作簿复制到一个主工作簿中

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

标签： excelvba

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