macro to copy and paste data from one Sheet to another when Header is matching

Question

I am trying to create a macro to copy and paste data from one Sheet to another sheet when Header and Column A data is matching and want to paste into the specific cell.

below code is working fine for me when Row(headers) order is the same in both sheets. but I need a solution for when the row (Headers) are not in the order.

"I hope I was able to explain my problem"

Sub transfer()
    Dim i As Long, j As Long, lastrow1 As Long, lastrow2 As Long
    Dim myname As String
    lastrow1 = Sheets("sheet1").Range("A" & Rows.Count).End(xlUp).Row

    For i = 2 To lastrow1
        myname = Sheets("sheet1").Cells(i, "A").Value
        Sheets("sheet2").Activate
        lastrow2 = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row

        For j = 2 To lastrow2       
            If Sheets("sheet2").Cells(j, "A").Value = myname Then
                Sheets("sheet1").Activate
                Sheets("sheet1").Range(Cells(i, "B"), Cells(i, "F")).Copy
                Sheets("sheet2").Activate
                Sheets("sheet2").Range(Cells(j, "D"), Cells(j, "H")).Select
                ActiveSheet.Paste
            End If
        Next j
        Application.CutCopyMode = False
    Next i

    Sheets("sheet1").Activate
    Sheets("sheet1").Range("A1").Select 
End Sub

Ahmed AU Ahmed AU · Accepted Answer · 2019-04-09T01:26:39

if i understood your goal then may try something like (code is tested with makeshift data)

Sub test()
Dim SrcWs As Worksheet, TrgWs As Worksheet
Dim Col As Long, TrgLastRw As Long, SrclastRw As Long, SrcLastCol As Long, TrgLastCol As Long
Dim SrcRng As Range, TrgRng As Range, C As Range, Hd As String
Set SrcWs = ThisWorkbook.Sheets("Sheet1")
Set TrgWs = ThisWorkbook.Sheets("Sheet2")
SrcLastCol = SrcWs.Cells(1, Columns.Count).End(xlToLeft).Column
TrgLastCol = TrgWs.Cells(1, Columns.Count).End(xlToLeft).Column

    For Col = 1 To SrcLastCol                   
    Hd = SrcWs.Cells(1, Col).Value
        If Hd <> "" Then
        SrclastRw = SrcWs.Cells(Rows.Count, Col).End(xlUp).Row + 1
        Set SrcRng = SrcWs.Range(SrcWs.Cells(2, Col), SrcWs.Cells(SrclastRw, Col))
            With TrgWs.Range(TrgWs.Cells(1, 1), TrgWs.Cells(1, TrgLastCol))
            Set C = .Find(Hd, LookIn:=xlValues)    'each column header is searched in trgWs
                If Not C Is Nothing Then
                TrgLastRw = TrgWs.Cells(Rows.Count, C.Column).End(xlUp).Row + 1
                Set TrgRng = TrgWs.Cells(TrgLastRw, C.Column).Resize(SrcRng.Rows.Count, 1)
                SrcRng.Copy Destination:=TrgRng
                End If
            End With
        End If
    Next Col
End Sub

macro to copy and paste data from one Sheet to another when Header is matching

1 Answers