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

Question

I want to open a workbook that contains only one sheet,
copy data up to column AC until last available row in column A,
paste the data into first empty row in column A in workbook "Mergedsheet.xlsx".

I want to loop over all workbooks present in a specific folder, but get lots of errors.

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

You are looping through a folder and copy-pasting each workbook's first sheet's data to workbook A. However, workbook A is also in that folder. So you should take care to skip it (when looping).

(Alternatively, you could provide a different argument to the DIR function (eg some wildcard criteria that excludes workbook A if possible), so that you don't have to constantly check inside the loop.)

Untested.

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