transfer data from 1 sheet to other multiple sheets in same workbook based on column header-CodePudding

I've got a workbook with 11 worksheets. Every workbook has Row 1 as column headers. Some of the column headers are common to all worksheets, but they are not consistently in the same order.

Sheet1 is source sheet. I want to transfer the data from sheet1 to all other sheets based on their column header. I tried to modified a code but its working only for 1 target sheet.

  Sub AG()

    Dim ws_B As Worksheet
    Dim HeaderRow_A As Long
    Dim HeaderLastColumn_A As Long
    Dim TableColStart_A As Long
    Dim NameList_A As Object
    Dim SourceDataStart As Long
    Dim SourceLastRow As Long
    Dim Source As Variant
    Dim rowTarget As Long
    Dim iHighestUsedRow&
    Dim LastRow As Long
    Dim i As Long
    Dim ws_B_lastCol As Long
    Dim NextEntryline As Long
    Dim SourceCol_A As Long
 
    Set ws_A = Worksheets("Sheet1")
    Set ws_B = Worksheets("Sheet2")
    Set NameList_A = CreateObject("Scripting.Dictionary")
   
    With ws_A
        SourceDataStart = 2
        HeaderRow_A = 1
        TableColStart_A = 1
        HeaderLastColumn_A = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column
        
        iHighestUsedRow = 0
        
        For i = TableColStart_A To HeaderLastColumn_A
            If Not NameList_A.Exists(UCase(.Cells(HeaderRow_A, i).Value)) Then
                NameList_A.Add UCase(.Cells(HeaderRow_A, i).Value), i
            End If
        Next i
    End With

    With ws_B
        ws_B_lastCol = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column
        
        For i = 1 To ws_B_lastCol
            SourceLastRow = .Cells(Rows.Count, i).End(xlUp).Row
            
            If SourceLastRow > iHighestUsedRow Then
                iHighestUsedRow = SourceLastRow
            End If
        Next i
    End With

    With ws_B
        For i = 1 To ws_B_lastCol
            SourceCol_A = NameList_A(UCase(.Cells(1, i).Value))
    
            If SourceCol_A <> 0 Then
                SourceLastRow = ws_A.Cells(Rows.Count, SourceCol_A).End(xlUp).Row
                
                If SourceLastRow > 1 Then
                    Set Source = ws_A.Range(ws_A.Cells(SourceDataStart, SourceCol_A), ws_A.Cells(SourceLastRow, SourceCol_A))
                    NextEntryline = iHighestUsedRow   1
        
                    .Range(.Cells(NextEntryline, i), _
                           .Cells(NextEntryline, i)) _
                           .Resize(Source.Rows.Count, Source.Columns.Count).Cells.Value = Source.Cells.Value
                End If
            End If

        Next i
    End With

   End Sub

CodePudding user response：

Please, try the next updated code:

Sub AG()
    Dim ws_B As Worksheet, HeaderRow_A As Long, HeaderLastColumn_A As Long, TableColStart_A As Long
    Dim NameList_A As Object, SourceDataStart As Long, SourceLastRow As Long, Source As Variant, LastRow As Long
    Dim i As Long, ws_B_lastCol As Long, NextEntryline As Long, SourceCol_A As Long, iHighestUsedRow As Long
    Dim ws_A As Worksheet
    
    Set ws_A = Worksheets("Sheet1")
    'Set ws_B = Worksheets("Sheet2")
    Set NameList_A = CreateObject("Scripting.Dictionary")
   
    With ws_A
        SourceDataStart = 2
        HeaderRow_A = 1
        TableColStart_A = 1
        HeaderLastColumn_A = .cells(HeaderRow_A, Columns.count).End(xlToLeft).Column
        
        'iHighestUsedRow = 0
        
        For i = TableColStart_A To HeaderLastColumn_A
            If Not NameList_A.Exists(UCase(.cells(HeaderRow_A, i).Value)) Then
                NameList_A.Add UCase(.cells(HeaderRow_A, i).Value), i
            End If
        Next i
    End With
    For Each ws_B In ActiveWorkbook.Worksheets
        If ws_B.name <> ws_A.name Then 'exclude the sheet where to copy from
            iHighestUsedRow = 0
            With ws_B
                ws_B_lastCol = .cells(HeaderRow_A, Columns.count).End(xlToLeft).Column
                
                For i = 1 To ws_B_lastCol
                    SourceLastRow = .cells(rows.count, i).End(xlUp).row
                    
                    If SourceLastRow > iHighestUsedRow Then
                        iHighestUsedRow = SourceLastRow
                    End If
                Next i

                For i = 1 To ws_B_lastCol
                    SourceCol_A = NameList_A(UCase(.cells(1, i).Value))
            
                    If SourceCol_A <> 0 Then
                        SourceLastRow = ws_A.cells(rows.count, SourceCol_A).End(xlUp).row
                        
                        If SourceLastRow > 1 Then
                            Set Source = ws_A.Range(ws_A.cells(SourceDataStart, SourceCol_A), ws_A.cells(SourceLastRow, SourceCol_A))
                            NextEntryline = iHighestUsedRow   1
                
                            .Range(.cells(NextEntryline, i), _
                                   .cells(NextEntryline, i)) _
                                   .Resize(Source.rows.count, Source.Columns.count).cells.Value = Source.cells.Value
                        End If
                    End If
        
                Next i
            End With
        End If
   Next ws_B
End Sub

CodePudding user response：

Copy to Multiple Worksheets With Differently Arranged Headers

Option Explicit

Sub CopyToMultipleWorksheets()

    ' Reference the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source worksheet ('sws').
    Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
    
    ' Declare variables.
    Dim sdrg As Range ' Source Data Range (no headers)
    Dim shData() As Variant ' Source Header Array
    Dim srCount As Long ' Number of Rows in the Source Data Range
    Dim scCount As Long ' Number of Columns in the Source Data/Header Range
    
    ' Reference the source range (has headers).
    With sws.Range("A1").CurrentRegion
        ' Write the values from the first row to a 2D one-based one-row array,
        ' the source header array ('shdata').
        shData = .Rows(1).Value
        ' Write the number of rows of the source data range (no headers)
        ' to a variable ('srCount').
        srCount = .Rows.Count - 1
        ' Write the number of columns to a variable ('scCount').
        scCount = .Columns.Count
        ' Reference the source data range ('sdrg').
        Set sdrg = .Resize(srCount).Offset(1)
    End With
    
    ' Create and reference a new dictionary object ('dict').
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' case-insensitive i.e. 'A = a'
    
    ' Declare variables.
    Dim sc As Long ' Current Source Column
    
    ' Write the headers to the 'keys' and the values from the corresponding
    ' source data range columns to the associated 'items' of the dictionary.
    For sc = 1 To scCount
        dict(CStr(shData(1, sc))) = sdrg.Columns(sc).Value
    Next sc
    
    ' Declare variables.
    Dim dws As Worksheet ' Destination Worksheet
    Dim drg As Range ' Destination Range
    Dim dhData() As Variant ' Destination Header Array
    Dim dcCount As Long ' Number of Columns in the Destination Data/Header Range
    Dim dc As Long ' Destination Column
    Dim dHeader As String ' Destination Header
    
    ' Loop through worksheets...
    For Each dws In wb.Worksheets
        If Not dws Is sws Then ' it's not the source worksheet
            ' Reference the (currently occupied) destination range.
            With dws.Range("A1").CurrentRegion
                ' Write the values from the first row to a 2D one-based one-row
                ' array, the destination header array ('dhdata').
                dhData = .Rows(1).Value
                ' Write the number of columns to a variable ('dcCount').
                dcCount = .Columns.Count
                ' Reference the range that will be written to,
                ' the destination range ('drg').
                Set drg = .Resize(srCount).Offset(.Rows.Count)
            End With
            ' Loop through the columns...
            For dc = 1 To dcCount
                ' Write the current header to a string variable ('dHeader').
                dHeader = CStr(dhData(1, dc))
                ' Check if the destination header exists in the dictionary.
                If dict.Exists(dHeader) Then ' the header exists
                    drg.Columns(dc).Value = dict(dHeader) ' write
                'Else ' the header doesn't exist; do nothing
                End If
            Next dc
        'Else ' it's the source worksheet; do nothing
        End If
    Next dws
    
    ' Save the workbook.
    'wb.Save
    
    ' Inform.
    MsgBox "Data copied.", vbInformation

End Sub