макрос для копирования и вставки данных из одного листа в другой при совпадении заголовка

Question

Я пытаюсь создать макрос для копирования и вставки данных из одного листа в другой, когда данные заголовка и столбца A совпадают и требуется вставить в определенную ячейку.

код ниже работает нормально для меня, когда порядок строк (заголовков) одинаков на обоих листах.но мне нужно решение, когда строка (Заголовки) не в порядке.

«Я надеюсь, что смог объяснить мою проблему»

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

Answer 1

если я понял вашу цель, то может попробовать что-то вроде (код проверен с временными данными)

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