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

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

1 个答案: