Copy the same range of cells from multiple Excel files using VBA

Question

I have a macro that takes data from one Workbook and copies it into another Workbook. Currently it is set that it copies files from Book2.xlsx into Book1.xlsm. It only works if I have Book2 and Book1 open. However, I would like to use this macro, so that it runs on all the Excel files in my folder, so for example if I have also Book5.xlsm, Book15.xlsx and Book153.xlsx in folder C:\Users\JJ\Documents\Downloads, I would like to copy and paste cells "D25:D26, D29:D32, D35" from all these files into Book1.xlsm. How to automate that process, so that I do not have to manually enter the name of file in the code each time? Thank you in advance for your help.

Sub Copy_Form_Below_Last_Cell() 
Dim wsDest As Worksheet
Dim lDestLastRow As Long
Set wsDest = Workbooks("Book1.xlsm").Worksheets("Sheet1")
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "H").End(xlUp).Offset(1).Row
Workbooks("Book2.xlsx").Worksheets("Sheet_2").Range("D25:D26, D29:D32, D35").Copy _
wsDest.Range("H" & lDestLastRow)     
wsDest.Activate
End Sub

Answer 1

This is the code that will do whatever your original code did - to many. Sorry, it's a bit voluminous. That's because I took a ready function from my shelf to allow you file selection. You can select one file or many, but all must be in the same directory.

Sub CopyFormToNewRow()

    Dim FileNames As Variant
    Dim wsDest As Worksheet
    Dim Wb As Workbook
    Dim wsSrc As Worksheet
    Dim WasClosed As Boolean
    Dim Tmp As Variant
    Dim i As Integer

    FileNames = FileOpenName("Workbooks to process", "Excel workbooks|*.xlsx", Multi:=True)
    If Not IsEmpty(FileNames) Then
        Set wsDest = Workbooks("Book1.xlsm").Worksheets("Sheet1")

        Application.ScreenUpdating = False
        For i = 1 To UBound(FileNames)
            On Error Resume Next
            Tmp = Split(FileNames(i), "\")
            Set Wb = Workbooks(Tmp(UBound(Tmp)))
            If Err Then
                Set Wb = Workbooks.Open(FileNames(i))
            End If
            WasClosed = CBool(Err.Number)

            On Error GoTo 0
            Set wsSrc = Wb.Worksheets("Sheet_2")
            ' I would prefer: Set wsSrc = Wb.Worksheets(1), meaning first worksheet
            With wsDest
                wsSrc.Range("D25:D26, D29:D32, D35").Copy _
                      Destination:=.Cells(.Rows.Count, "H").End(xlUp).Offset(1)
            End With
            If Not WasClosed Then Wb.Close SaveChanges:=False
        Next i

        Application.ScreenUpdating = True
    End If
End Sub

Function FileOpenName(ByVal Title As String, _
                      Optional ByVal Fltr As String, _
                      Optional ByVal Pn As String, _
                      Optional ByVal Multi As Boolean) As Variant
    ' SSY 050 28 Jan 2020

    ' ==================================================
    '   Parameters:
    '       Title             = Form's title
    '       Fltr              = Specify filters by structured string
    '                           i.e. "Excel workbooks|*.xl*||Word documents|*.doc*"
    '                           in sequence of position assignment.
    '                           separator = Chr(124) - single and double
    '                           Default = no filter [=All files]
    '       Pn                  = Initial path: [=Last used]

    ' ==================================================
    '   Return                = Single file Ffn string or a 1-based array
    '                           Return IsEmpty if no selection was made

    ' ==================================================
    '   Note:   The ButtonName is "Open" by default. Another setting
    '           doesn't take effect until a file has been selected.

    ' ==================================================

    Const FltDesc As Long = 0, FltExt As Long = 1

    Dim Fun As Variant                              ' return variant
    Dim Fod As FileDialog                           ' File Open Dialog
    Dim Flt() As String                             ' all filters
    Dim Sp() As String                              ' split filter
    Dim i As Long

    ' ==================================================

    Flt = Split(Fltr, "||")

    Set Fod = Application.FileDialog(msoFileDialogFilePicker)
    With Fod
        .Filters.Clear
        For i = 0 To UBound(Flt)
            If Len(Flt(i)) Then
                Sp = Split(Flt(i), "|")
                .Filters.Add Sp(FltDesc), Sp(FltExt), i + 1
                .FilterIndex = 1
            End If
        Next i
        .Title = Title
        .AllowMultiSelect = Multi
        .InitialFileName = Pn
        If .Show Then
            With .SelectedItems
                If Multi Then
                    ReDim Fun(.Count)
                    For i = 1 To .Count
                        Fun(i) = .Item(i)
                    Next i
                Else
                    Fun = .Item(1)
                End If
            End With
        End If
    End With

    FileOpenName = Fun
End Function

Answer 2

Import From Many Workbooks

Option Explicit

Sub Copy_Form_Below_Last_Cell()

    Const cFolder As String = "C:\Users\JJ\Documents\Downloads"
    Const cDest As String = "Sheet1"                ' Destination Worksheet Name
    Const cSource As String = "Sheet_2"             ' Source Worksheet Name
    Const cRng As String = "D25:D26, D29:D32, D35"  ' Source Range Address
    Const cExt As String = "*.xl*"                  ' File Extensions
    Const cCol As Long = 8                          ' Destination Column Number

    Dim wbSource As Workbook                        ' Source Workbook
    Dim wsDest As Worksheet                         ' Destination Worksheet
    Dim CPR As Long                                 ' Current Paste Row
    Dim strName As String                           ' Current File Name

    Set wsDest = ThisWorkbook.Worksheets(cDest)

    ' Speed up.
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With

    ' Handle errors.
    On Error GoTo ErrorHandler

    ' Loop through all workbooks in Source Folder.
    strName = Dir(cFolder & "\" & cExt)
    Do While Len(strName) > 0  ' and strname<>
        Set wbSource = Workbooks.Open(cFolder & "\" & strName)
        CPR = wsDest.Cells(wsDest.Rows.Count, cCol).End(xlUp).Row + 1
        wbSource.Worksheets(cSource).Range(cRng).Copy wsDest.Cells(CPR, cCol)
        wbSource.Close False
        strName = Dir
    Loop

ProcedureExit:

    ' Speed down.
    With Application
        .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

Exit Sub

ErrorHandler:
    MsgBox "An unexpected error occurred."
    On Error GoTo 0
    GoTo ProcedureExit

End Sub