CODEWITHSUNDEEP
excelvba
Herman
Herman

Reputation: 157

Excel VBA consolidate several workbooks into one sheet

Good day all,

I have managed to scrape this code together, which works, BUT I need all the data on only 1 sheet, pasted on the first blank cell in column A. I have noticed Copy.Range, but it battling to integrate it into this code.

Sub ConsolidateWorkbooks()
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Application.ScreenUpdating = False
FolderPath = "P:\FG\03_OtD_Enabling\Enabling\Teams\Enabling_RPA\Other Automations\Excel Merge Several Files\Data\"
Filename = Dir(FolderPath & "*.xls*")
Do While Filename <> ""
 Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
    For Each thisSheet In ActiveWorkbook.Worksheets
    thisSheet.Copy After:=ThisWorkbook.Worksheets(1)
    Next thisSheet
 Workbooks(Filename).Close
 Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub

Upvotes: 0

Views: 131

Answers (1)

FaneDuru
FaneDuru

Reputation: 42256

Try the next code, please. It copies the sheets content starting from the second row (I only presume that the first row keeps column headers). If you need to copy everything, the code will be even simpler, The code should be fast enough, using an array to copy the range (without formatting):

Sub ConsolidateWorkbooks()
Dim FolderPath As String, Filename As String, sh As Worksheet, ShMaster As Worksheet
Dim wbSource As Workbook, lastER As Long, arr

'adding a new sheet on ThisWorkbook (after the last existing one)
Set ShMaster = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Sheets.count))

Application.ScreenUpdating = False
FolderPath = "P:\FG\03_OtD_Enabling\Enabling\Teams\Enabling_RPA\Other Automations\Excel Merge Several Files\Data\"
Filename = Dir(FolderPath & "*.xls*")
  Do While Filename <> ""
    'set the workbook to be open:
    Set wbSource = Workbooks.Open(Filename:=FolderPath & Filename, ReadOnly:=True)
    For Each sh In ActiveWorkbook.Worksheets    'iterate between its sheets
        lastER = ShMaster.Range("A" & rows.count).End(xlUp).row 'last empty row
        'put the sheet range in an array:
        arr = sh.Range(sh.UsedRange.cells(1, 1).Offset(1, 0), _
                sh.cells(sh.UsedRange.rows.count - sh.UsedRange.row + 1, _
                                       sh.UsedRange.Columns.count)).Value
        'drop the array content at once:
        ShMaster.Range("A" & lastER).Resize(UBound(arr), UBound(arr, 2)).Value = arr
    Next sh
    wbSource.Close    'close the workbook
    Filename = Dir()  'find the next workbook in the folder
  Loop
 Application.ScreenUpdating = True
End Sub

Upvotes: 2

Related Questions