Copy Range from multiple workbooks in folder to Summary Workbook also in folder?

Question

I have a folder with 100+ workbooks. These workbooks contain a range of data. For simplicity I will call the data range A1:D2, the range is located on Sheet1 of all 100+ workbooks.

I also have a Summary workbook.

I would like to place VBA code in the Summary workbook that loops through the folder, copying the range A1:D2 of each of the 100+ workbooks.

I would then like to paste the A1:D2 range from each workbook in to Sheet1 of the Summary workbook. Each paste will start on the next unused row.

I am stuck doing this via a manual process right now and it is driving me insane.

I do know some basic VBA coding however my problem is that I can't figure out how to loop it correctly, and I am stuck coding each individual workbook to open-->copy-->paste-->close. This was fine with 10-20 workbooks but now I am at 100+ and it is growing every week.

Thanks again,

Brian

Answer 1

Try this

Sub combine_into_one()
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim strPath$, Pivot$, sUserName$, sFolderName$, sSourceName$, x&
Dim oFldialog As FileDialog
Dim oFile As Scripting.File
Dim oFolder

Set oFldialog = Application.FileDialog(msoFileDialogFolderPicker)

With oFldialog
    If .Show = -1 Then
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        sFolderName = .SelectedItems(1)
    End If
End With

Set oFolder = FSO.GetFolder(sFolderName)

Workbooks.Add: Pivot = ActiveWorkbook.Name 'Destination workbook

For Each oFile In oFolder.Files
    Workbooks(Pivot).Activate

    x = Workbooks(Pivot).Sheets("Sheet1").Cells.SpecialCells(xlCellTypeLastCell).Row + 1

    Workbooks.Open filename:=oFile: sSourceName = ActiveWorkbook.Name
    Workbooks(sSourceName).Activate
        Workbooks(sSourceName).Sheets("Sheet1").[A1:D1].Copy

    Workbooks(Pivot).Activate
    Workbooks(Pivot).Sheets("Sheet1").Cells(x, 1).PasteSpecial xlPasteAll
    Workbooks(sSourceName).Close False
Next

End Sub

Answer 2

I have something that does exactly what you are asking for, if you want to copy multiple workbooks I suggest creating a new worksheet to capture the workbook information onto a spreadsheet. Instructions below

1. Create a new worksheet and give it a name, in this case we'll call the sheet 'Control'

2. Create a new module in VBA and use the code below to operate the workbook copy

I have left a section out for you to write your code for the functions that you want to perform.

Sub WorkbookConsolidator()

Dim WB As Workbook, wb1 as workbook
Dim WBName as Range 
Dim folderselect as Variant, wbA as Variant, wbB as Variant, 
Dim I as long, J as long
Dim objFolder As Object, objFile As Object
Dim WBRange as String

'Set Core Variables and Open Folder containing workbooks.

 Set WB = ThisWorkbook
 Worksheets("Control").Activate
 Set FolderSelect = Application.FileDialog(msoFileDialogFolderPicker)
 FolderSelect.AllowMultiSelect = False
 MsgBox ("Please Select the Folder containing your Workbooks")
 FolderSelect.Show
 WBRange = FolderSelect.SelectedItems(1)
 Set objFolder = objFSO.GetFolder(FolderSelect.SelectedItems(1))


' Fill out File name Fields in Control Sheet 
' The workbook names will be captured in Column B
' This allows allocation for up to 100 workbooks
For I = 1 To 100
    For Each objFile In objFolder.files
    If objFile = "" Then Exit For
       Cells(I, 2) = objFile.Name ' Workbook Name
       Cells(I, 3) = WBRange ' Workbook Path
       I = I + 1
       Next objFile
    Next I

'Loop through the list of workbooks created in the 'Control' Directory, adjust the loop range as preferred
For J = 100 To 1 Step -1
      With Workbooks(ThisWorkbook).Worksheets("Control")
         BookLocation = .Range("C" & J).Value
         BookName = .Range("B" & J).Value
      End With

    Set wb1 = Workbooks.Open(Booklocation & Bookname)

    ' Write your code here'



       CleanUp:
       wb1.Close SaveChanges:=False

Next J

End Sub()

`