How to open multiple workbooks to copy the data from

Question

I've written a script in vba which is able to import a .xlsx file from a specific folder in my desktop and copy the data from there in order to paste the same in my currently active worksheet. My script is doing fine for a single .xlsx file.

The folder contains 100's of .xlsx files. Each of the files in their Sheet1 having data with fixed coulmns (rows may vary).

What I wish to do now is get all the data from those files one by one in my active worksheet (appended one after another in row-wise).

My attempt so far:

Sub OpenAndImportFile()
    Dim wbO As Workbook, wsI As Worksheet, cel As Range

    Set wsI = ThisWorkbook.Worksheets("Sheet1")

    Set wbO = Workbooks.Open("C:\Users\WCS\Desktop\files\coworking\list_members-coworking-annkingman-2018-12-31-14-55-07-eisaiah_e.xlsx")

    For Each cel In wbO.Sheets(1).Range("A1:A" & wbO.Sheets(1).Cells(Rows.count, 1).End(xlUp).row)
        cel(1, 1).EntireRow.Copy wsI.Range(cel(1, 1).Address)
    Next cel

    wbO.Close SaveChanges:=False
End Sub

Answer 1

Using VBA (instead of something like Power Query) and assuming you want to copy the data from the first sheet (of the workbook you open) and paste to "Sheet1" in Thisworkbook, the code might look something like the below.

Might be good to make a copy of the entire folder (containing .xlsx files) before running the code below (unnecessary, but just in case).

If you have hundreds of files to open, you might want to toggle Application.ScreenUpdating before and after the For loop (to prevent unnecessary screen flickering and redrawing).

Option Explicit

Private Sub CopyPasteSheets()
    Dim folderPath As String
    folderPath = "C:\Users\WCS\Desktop\files\coworking\"

    If Len(VBA.FileSystem.Dir$(folderPath, vbDirectory)) = 0 Then
        MsgBox ("'" & folderPath & "' does not appear to be a valid directory." & vbNewLine & vbNewLine & "Code will stop running now.")
        Exit Sub
    End If

    Dim filePathsFound As Collection
    Set filePathsFound = New Collection

    Dim Filename As String
    Filename = VBA.FileSystem.Dir$(folderPath & "*.xlsx", vbNormal)

    Do Until Len(Filename) = 0
        filePathsFound.Add folderPath & Filename, Filename
        Filename = VBA.FileSystem.Dir$()
    Loop

    Dim filePath As Variant ' Used to iterate over collection
    Dim sourceBook As Workbook

    Dim destinationSheet As Worksheet
    Set destinationSheet = ThisWorkbook.Worksheets("Sheet1") ' Change to whatever yours is called
    'destinationSheet.Cells.Clear ' Uncomment this line if you want to clear before beginning

    Dim rowToPasteTo As Long
    rowToPasteTo = destinationSheet.Cells(destinationSheet.Rows.Count, "A").End(xlUp).Row
    If rowToPasteTo > 1 Then rowToPasteTo = rowToPasteTo + 1

    For Each filePath In filePathsFound
        On Error Resume Next
        Set sourceBook = Application.Workbooks.Open(Filename:=filePath, ReadOnly:=True)
        On Error GoTo 0

        If Not (sourceBook Is Nothing) Then
            With sourceBook.Worksheets(1) ' Might be better if you refer to sheet by name rather than index
                Dim lastRowToCopy As Long
                lastRowToCopy = .Cells(.Rows.Count, "A").End(xlUp).Row

                With .Range("A1:A" & lastRowToCopy).EntireRow
                    If (rowToPasteTo + .Rows.Count - 1) > destinationSheet.Rows.Count Then
                        MsgBox ("Did not paste rows from '" & sourceBook.FullName & "' due to lack of rows on sheet." & vbNewLine & vbNewLine & "Code will close that particular workbook and then stop running.")
                        sourceBook.Close
                        Exit Sub
                    End If

                    .Copy destinationSheet.Cells(rowToPasteTo, "A").Resize(.Rows.Count, 1).EntireRow
                    rowToPasteTo = rowToPasteTo + .Rows.Count
                End With
            End With
            sourceBook.Close
            Set sourceBook = Nothing
        Else
            MsgBox ("Could not open file at '" & CStr(sourceBook) & "'. Will try to open remaining workbooks.")
        End If
    Next filePath
End Sub

Answer 2

Open and Import File

The Code

Sub OpenAndImportFile()

    ' Source File Folder Path
    Const cStrFolder As String = "C:\Users\WCS\Desktop\files\coworking"
    Const cStrExt As String = "*.xls*"         ' Source File Pattern
    Const cVntSrcName As Variant = 1           ' Source Worksheet Name/Index
    Const cVntSource As Variant = "A"          ' Source Column Letter/Number

    Const cVntTgtName As Variant = "Sheet1"    ' Target Worksheet Name/Index
    Const cVntTarget As Variant = "A"          ' Target Column Letter/Number

    Dim objWbSource As Workbook   ' Source Workbook
    Dim objRngU As Range          ' Source Union Range
    Dim StrFile As String         ' Source File Name
    Dim i As Long                 ' Source Row Counter
    Dim j As Long                 ' Target Row Counter

    Dim objWsTarget As Worksheet  ' Target Worksheet
    Dim cLngPasteRow As Long      ' Target Paste Row

    Set objWsTarget = ThisWorkbook.Worksheets(cVntTgtName)
    objWsTarget.Cells.Clear

    cLngPasteRow = 1

    StrFile = Dir(cStrFolder & "\" & cStrExt)

    On Error GoTo ProcedureExit

    With Application
      .ScreenUpdating = False
      .Calculation = xlCalculationManual
      .DisplayAlerts = False
    End With

    Do While Len(StrFile) > 0

        Set objWbSource = Workbooks.Open(cStrFolder & "\" & StrFile)

        With objWbSource.Worksheets(1)

'            Debug.Print objWbSource.Name & "  " & .Name & "   " & cLngPasteRow

            If .Cells(.Rows.Count, cVntSource).End(xlUp).Row = 1 _
                And .Cells(1, 1) = "" Then
              Else
                For i = 1 To .Cells(.Rows.Count, cVntSource).End(xlUp).Row
                    If Not objRngU Is Nothing Then
                        Set objRngU = Union(objRngU, .Cells(i, cVntSource))
                      Else
                        Set objRngU = .Cells(i, cVntSource)
                    End If
                    j = j + 1
                Next
            End If
        End With

        If Not objRngU Is Nothing Then
            objRngU.EntireRow.Copy objWsTarget.Cells(cLngPasteRow, cVntTarget)
            Set objRngU = Nothing
            cLngPasteRow = j + 1 ' Next row to copy data to.
        End If

        objWbSource.Close False

        StrFile = Dir

    Loop

ProcedureExit:

    Set objRngU = Nothing
    Set objWbSource = Nothing
    Set objWsTarget = Nothing

    With Application
      .ScreenUpdating = True
      .Calculation = xlCalculationAutomatic
      .DisplayAlerts = True
    End With


End Sub

Answer 3

This is how I did to serve the purpose eventually:

Sub OpenAndImportFile()
    Dim wbO As Workbook, wsI As Worksheet, cel As Range
    Dim daddr$, Filename$, foundfiles As New Collection
    Dim xlfile As Variant

    Application.ScreenUpdating = False

    daddr = Environ("USERPROFILE") & "\Desktop\files\coworking\"
    Filename = Dir(daddr & "*.xlsx")
    Set wsI = ThisWorkbook.Worksheets("Sheet1")

    Do While Len(Filename) > 0
        foundfiles.Add Filename
        Filename = Dir
    Loop

    For Each xlfile In foundfiles
        Set wbO = Workbooks.Open(daddr & xlfile)

        For Each cel In wbO.Sheets(1).Range("A1:A" & wbO.Sheets(1).Cells(Rows.count, 1).End(xlUp).row)
            cel(1, 1).EntireRow.Copy wsI.Range("A" & Rows.count).End(xlUp).Offset(1, 0)
        Next cel
        wbO.Close SaveChanges:=False
    Next xlfile

    Application.ScreenUpdating = True
End Sub