Loop through multiple workbooks and copy into another existing workbook

Question

I'm looking for something somewhat complex. I have one master workbook (name: Verificari CE) and other workbooks are located in the same folder on desktop (folder name Verificari). If I can Loop through the entire .xls workbooks from that folder located on desktop named "Verificari" and copy the data from each workbook into this master workbook (Verificari CE).

Let's say I have these workbooks:

Verificari CE (master workbook)
Test A
Test B
Test C

Note: The name and the number (Test A; Test B; Test C….) of these workbooks will vary!

Here's how I need it to function:

Copy all rows with data from Test A’s Sheet1 to Verificari CE.
Then Check Test B's Sheet1 and copy all rows with data from A2, paste BELOW Campaign A's data on Verificari CE
Then Check Test C's Sheet1 and copy all rows with data, paste BELOW Campaign B's data on Verificari CE

I'm sorry I can't upload an example (I work for a data-sensitive company). Any help would be greatly appreciated!

Sub Copymultiple()
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
        .EnableEvents = False
    End With

    Dim VerificariCE As Workbook
    Dim TestA As Workbook
    Dim TestB As Workbook
    Dim TestC As Workbook

    Dim maxRow As Long
    Dim maxCol As Integer

    Dim nextRow As Long

    Set VerificariCE = Workbooks("Verificari CE.xlsm")

    With VerificariCE.Sheets(2)   
        Workbooks.Open .Cells(1, 1).Value
        Set TestA = ActiveWorkbook

        Workbooks.Open .Cells(2, 1).Value
        Set TestB = ActiveWorkbook

        Workbooks.Open .Cells(2, 1).Value
        Set TestC = ActiveWorkbook
    End With

    'Comment this out if you don't want to clear existing values
    VerificariCE.Sheets(1).UsedRange.Clear
    'Comment this out if you don't want to clear existing values

    nextRow = VerificariCE.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1

    With TestA.Sheets(1)
        .Activate
        maxRow = .Cells(Rows.Count, "A").End(xlUp).Row
        maxCol = .Cells(3, Columns.Count).End(xlToLeft).Column
        .Range(.Cells(3, 1), .Cells(maxRow, maxCol)).Copy
    End With

    VerificariCE.Activate
    VerificariCE.Sheets(1).Cells(nextRow, 1).Select
    ActiveSheet.Paste
    nextRow = VerificariCE.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1

    TestA.Close

    With TestB.Sheets(1)
        .Activate
        maxRow = .Cells(Rows.Count, "A").End(xlUp).Row
        maxCol = .Cells(3, Columns.Count).End(xlToLeft).Column
        .Range(.Cells(3, 1), .Cells(maxRow, maxCol)).Copy
    End With

    VerificariCE.Activate
    VerificariCE.Sheets(1).Cells(nextRow, 1).Select
    ActiveSheet.Paste
    nextRow = VerificariCE.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1

    TestB.Close

    With TestC.Sheets(1)
        .Activate
        maxRow = .Cells(Rows.Count, "A").End(xlUp).Row
        maxCol = .Cells(3, Columns.Count).End(xlToLeft).Column
        .Range(.Cells(3, 1), .Cells(maxRow, maxCol)).Copy
    End With

    VerificariCE.Activate
    VerificariCE.Sheets(1).Cells(nextRow, 1).Select
    ActiveSheet.Paste
    nextRow = VerificariCE.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1

    TestC.Close

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

    With VerificariCE.Sheets(1).UsedRange
        .Value = .Value
        .Activate
    End With

    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.EntireRow.Delete
End Sub

Harassed Dad Harassed Dad · Accepted Answer · 2019-03-11T10:55:07

Avoid using select. Use object variables to point to your objects. Use DIR to read the files in your folder.

Sub Example()
const foldername = "Verificari"
const mastername = "Verificari CE.xlsm"
Dim wb as workbook
Dim ws as Worksheet
Dim targetbook as workbook
Set targetbook = workbooks(mastername) 'I assume this code is in this file and it is therefore open
Dim targetsheet as worksheet
set targetsheet = worksheets(1) 'assume first sheet
Dim target as range
set target = targetsheet.range("a2")
Dim r as range
Dim s as string
s = dir(foldername & "*.xl*")  'read spreadsheet names
do while s <> ""
   if s = mastername then
   else
   set wb = workbooks.open(foldername & "\" & s)
   if not wb is nothing then
      set ws = wb.worksheets(1)
     '#########
      set r = targetsheet.range("a" & rows.count).end(xlup).offset(1,0)
      ws.usedrange.copy r
      '##########
      wb.close false
   end if
   end if   'missed this first time round
   s = dir()
loop
end sub

I can't test this so there may be typos

Loop through multiple workbooks and copy into another existing workbook

2 Answers