Поиск определенного текста, копирование всего текста под другой книгой под тем же текстом

Question

Я пытаюсь написать макрос, который проверяет «Лист1» на наличие определенных текстов.Например, «Голова 1» и «Голова 2».Если он находит эти тексты, каждая ячейка ниже должна быть скопирована под тем же «заголовком» в «Sheet2».

Sheet1:

Sheet2:

Результат после того, как Лист1 скопирован в Лист2:

У меня есть первый подход, но я не знаю, как продолжить.Любая помощь и предложение приветствуется.

Sub Test()

    Dim FindH1 As Range
        With Range("A:DD")

        Set FindH1 = .Find(What:="Head 1", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)

        If Not FindH1 Is Nothing Then

            '???

        End If

    End With   
End Sub

Answer 1

Это должно помочь вам, код объяснен, поэтому я думаю, вы можете пройти через это:

Option Explicit
Sub Test()

    'You need Microsoft Scripting Runtime for this to work
    Dim HeadersSheet1 As New Scripting.Dictionary 'Store the column index for each header on sheet1
    Dim HeadersSheet2 As New Scripting.Dictionary 'Store the column index for each header on sheet2
    Dim arrHeaders As Variant 'store all the headers you want to copy
    Dim i As Long 'for looping purpose
    Dim LastRow As Long 'Last row for each column on sheet1
    Dim Col As Long 'Get last column  each sheet1
    Dim C As Range 'Loop with cells is better with this

    arrHeaders = Array("Header1", "Header2", "Header3") 'here you input the headers you want to copy

    'First we store headers column index on sheet 1
    With ThisWorkbook.Sheets("Sheet1")
        Col = .Cells(1, .Columns.Count).End(xlToLeft).Column 'last column on row 1 for sheet1
        For Each C In .Range("A1", .Cells(1, Col)) 'loop through the headers
            HeadersSheet1.Add C.Value, C.Column 'store the header name with it's column
        Next C
    End With

    'Then we store headers column index on sheet 2
    With ThisWorkbook.Sheets("Sheet2")
        Col = .Cells(1, .Columns.Count).End(xlToLeft).Column 'last column on row 1 for sheet1
        For Each C In .Range("A1", .Cells(1, Col)) 'loop through the headers
            HeadersSheet1.Add C.Value, C.Column 'store the header name with it's column
        Next C
    End With

    Dim lrow As Long 'last row on sheet2
    Dim Col2 As Long 'column on sheet2

    'Finally we loop through the headers we want
    For i = LBound(arrHeaders) To UBound(arrHeaders)
        With ThisWorkbook.Sheets("Sheet2")
            Col2 = HeadersSheet2(arrHeaders(i)) 'find the header column on sheet2
            lrow = .Cells(.Rows.Count, Col2).End(xlUp).Row + 1 'find the next blank cell on that header
        End With
        End With
        With ThisWorkbook.Sheets("Sheet1")
            Col = HeadersSheet1(arrHeaders(i)) 'find the header column on sheet1
            LastRow = .Cells(.Rows.Count, Col).End(xlUp).Row 'find the last row on that header
            .Range(.Cells(2, Col), .Cells(LastRow, LastRow)) _
                .Copy ThisWorkbook.Sheets("Sheet2").Cells(lrow, Col2) 'copy the range
        End With
    Next i

End Sub