VBA to Consolidate data from folder to single sheet in Excel - excel

Question

I just found the below vba code from this forum and trying to include column headers of the excel files to be copied but no luck. please help.
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

Answer 1

Consolidate Workbooks
This will copy only the headers of each first worksheet of each workbook.
If you meant to copy the headers of each worksheet, it becomes much simpler i.e. surg, srCount and sIsFirstWorksheet become redundant:
For Each sws In swb.Worksheets
Set srg = sws.UsedRange
dCell.Resize(srg.Rows.Count, srg.Columns.Count).Value = srg.Value
Set dCell = dCell.Offset(srg.Rows.Count)
Next sws
If you want one or more empty rows between the data sets, you can easily implement a constant (e.g. Const Gap As Long = 1) and add it to the 'offset part':
Set dCell = dCell.Offset(srCount + Gap)
Option Explicit
Sub ConsolidateWorkbooks()
Const ProcTitle As String = "Consolidate Workbooks"
Const sFolderPath As String = "P:\FG\03_OtD_Enabling\Enabling\Teams\" _
& "Enabling_RPA\Other Automations\Excel Merge Several Files\Data\"
Const sFilePattern As String = "*.xls*"
' Source (Are there any files?)
Dim sFileName As String: sFileName = Dir(sFolderPath & sFilePattern)
If Len(sFileName) = 0 Then
MsgBox "No files to process.", vbCritical, ProcTitle
Exit Sub
End If
Application.ScreenUpdating = False
' Destination (Workbook - Worksheet - Range (First Cell))
Dim dwb As Workbook: Set dwb = ThisWorkbook
Dim dws As Worksheet ' note 'Worksheets vs Sheets':
Set dws = dwb.Worksheets.Add(After:=dwb.Sheets(dwb.Sheets.Count))
Dim dCell As Range
Set dCell = dws.Cells(dws.Rows.Count, 1).End(xlUp).Offset(1)
' Source (Variables)
Dim swb As Workbook
Dim sws As Worksheet
Dim surg As Range
Dim srg As Range
Dim srCount As Long
Dim sFilePath As String
Dim sIsFirstWorksheet As Boolean
Do While Len(sFileName) > 0
sFilePath = sFolderPath & sFileName
Set swb = Workbooks.Open(Filename:=sFilePath, ReadOnly:=True)
sIsFirstWorksheet = True
For Each sws In swb.Worksheets
Set surg = sws.UsedRange
If sIsFirstWorksheet Then ' copy headers
srCount = surg.Rows.Count
Set srg = surg
sIsFirstWorksheet = False
Else ' don't copy headers
srCount = surg.Rows.Count - 1
Set srg = surg.Resize(srCount).Offset(1)
End If
dCell.Resize(srCount, srg.Columns.Count).Value = srg.Value
Set dCell = dCell.Offset(srCount)
Next sws
swb.Close SaveChanges:=False
sFileName = Dir
Loop
'dwb.Save
Application.ScreenUpdating = True
MsgBox "Workbooks consolidated.", vbInformation, ProcTitle
End Sub