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

CodePudding user response：

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