Копировать строки нескольких рабочих книг в одну основную рабочую книгу.

Question

Я хочу открыть рабочую книгу, которая содержит только один лист,
копировать данные до столбца AC до последней доступной строки в столбце A,
вставьте данные в первую пустую строку в столбце A в книге "Mergedsheet.xlsx".

Я хочу перебрать все книги, представленные в определенной папке, но получаю много ошибок.

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