查找某个文本，将文本下方的所有内容复制到另一个工作簿中的同一文本下

Question

我正在尝试编写一个宏，该宏在“ Sheet1”中检查某些文本。例如“ Head 1”和“ Head 2”。如果他找到了这些文本，则下面的每个单元格都应复制到“ Sheet2”中相同的“ headtext”下。

Sheet1：

Sheet2：

在Sheet2中复制Sheet1之后的结果：

我有第一种方法，但我不知道如何继续。任何帮助和建议，表示赞赏。

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