VBA to merge data from multiple sheets along with sheet name

[aaleem]

Hi,

i have the below VBA code which merges the data from multiple sheets in a workbook and arranges the data based on the column headers. i would like to amend this code to add the sheet name as well in column BH. any help will be much appreciated.

Sub CopyHeaders()
    Dim header As Range, headers As Range
    Dim ws2 As Worksheet
    Dim Template As Worksheet
    Dim cell As Range
    
    For Each ws2 In ActiveWorkbook.Worksheets
    If IsError(Application.Match(ws2.Name, _
    Array("Template", "Sheet1"), 0)) Then
    Set Rng = ws2.UsedRange
    For Each cell In Rng
      If cell.Value = "" Then cell.Value = "0"

    Next
    Set headers = ws2.Range("A1:bg1")
    For Each header In headers
        If GetHeaderColumn(header.Value) > 0 Then
        Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("Template").Cells(Worksheets("Template").Rows.Count, GetHeaderColumn(header.Value)).End(xlUp).Offset(1, 0)
        
        End If
    
    Next
    End If
    Next
End Sub
Function GetHeaderColumn(header As String) As Integer
    Dim headers As Range
    Set headers = Worksheets("Template").Range("A1:bg1")
    GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function

thanks
aleem

 

[Fluff]

How about

    For Each header In headers
        If GetHeaderColumn(header.Value) > 0 Then
            NxtRw = Worksheets("Template").Cells(Worksheets("Template").Rows.Count, GetHeaderColumn(header.Value)).End(xlUp).Offset(1).Row
            With Range(header.Offset(1, 0), header.End(xlDown))
               .Copy Worksheets("Template").Cells(NxtRw, GetHeaderColumn(header.Value))
               Worksheets("Template").Cells(NxtRw, "BM").Resize(.Rows.Count).Value = ws2.Name
            End With
        
        End If
    
    Next

 

[aaleem]

How about

    For Each header In headers
        If GetHeaderColumn(header.Value) > 0 Then
            NxtRw = Worksheets("Template").Cells(Worksheets("Template").Rows.Count, GetHeaderColumn(header.Value)).End(xlUp).Offset(1).Row
            With Range(header.Offset(1, 0), header.End(xlDown))
               .Copy Worksheets("Template").Cells(NxtRw, GetHeaderColumn(header.Value))
               Worksheets("Template").Cells(NxtRw, "BM").Resize(.Rows.Count).Value = ws2.Name
            End With
       
        End If
   
    Next

Thank you so much Fluff, Excellent piece of code, it works perfectly. below is the final code, i just change the destination cell to BH to suit my data table

Sub CopyHeaders()
    Dim header      As Range, headers As Range
    Dim ws2         As Worksheet
    Dim Template    As Worksheet
    Dim cell        As Range
    
    For Each ws2 In ActiveWorkbook.Worksheets
        If IsError(Application.Match(ws2.Name, _
           Array("Template", "Sheet1"), 0)) Then
        Set Rng = ws2.UsedRange
        For Each cell In Rng
            If cell.Value = "" Then cell.Value = "0"
            
        Next
        Set headers = ws2.Range("A1:BG1")
        
        For Each header In headers
        If GetHeaderColumn(header.Value) > 0 Then
            NxtRw = Worksheets("Template").Cells(Worksheets("Template").Rows.Count, GetHeaderColumn(header.Value)).End(xlUp).Offset(1).Row
            With Range(header.Offset(1, 0), header.End(xlDown))
               .Copy Worksheets("Template").Cells(NxtRw, GetHeaderColumn(header.Value))
               Worksheets("Template").Cells(NxtRw, "BH").Resize(.Rows.Count).Value = ws2.Name
            End With
        
        End If
    
    Next
        
        
        
    End If
Next

End Sub
Function GetHeaderColumn(header As String) As Integer
    Dim headers     As Range
    Set headers = Worksheets("Template").Range("A1:BG1")
    GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
    
End Function

 

[Fluff]

You're welcome & thanks for the feedback.