Как я могу сопоставить соответствующее значение ячейки на основе ключевого слова, используя VBA?

Question

У меня есть макрос, который очищает данные и возвращает результаты на отдельную таблицу.Однако эти результаты необходимо обработать, чтобы все заголовки были извлечены в одном столбце в разделе «Результаты поиска».Я не могу понять, как написать функцию, которая будет возвращать все значения, связанные с термином «TI».Я написал некоторый код, но он не работает.Буду признателен за любую помощь или предложения по этому вопросу.

Рабочая таблица результатов поиска

Рабочая таблица необработанных данных

Sub Returnresults ()

 Dim r As Range

 Application.ScreenUpdating = False

 With Worksheets("Search Results")
.AutoFilterMode = False
.Range("A:A").AutoFilter Field:=1, Criteria1:="=TI"
With .AutoFilter.Range
    On Error Resume Next
    Set r = .Resize(.Rows.Count - 1, 1).Offset(1, 
    2).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Not r Is Nothing Then
        r.Copy Worksheets("Search Results").Range("A7")
    End If
End With
.AutoFilterMode = False
 End With

 Application.ScreenUpdating = True

 End Sub

Answer 1

вот какой должен быть рабочий код с минимальными отклонениями (пояснения в комментариях) от вашего

Option Explicit

Sub ReturnResults()

    Dim r As Range

    Application.ScreenUpdating = True

    With Worksheets("Sheet1") ' reference results sheet
        If IsEmpty(.Range("A1")) Then .Range("A1").Value = "dummy header" ' if A1 is empty, put a "dummy" header to make AutoFilter work properly

        .AutoFilterMode = False
        With .Range("B1", .Cells(.Rows.Count, 2).End(xlUp)).Offset(, -1) ' reference referenced sheet column A range from row 1 down to column B last not empty cell
            .SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C" ' fill referenced range blank cells with the same value as the not empty cell above
            .AutoFilter Field:=1, Criteria1:="=TI"
            On Error Resume Next
            Set r = .Resize(.Rows.Count - 1, 1).Offset(1, 1).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            If Not r Is Nothing Then r.Copy Worksheets("Search Results").Range("B7")
            .Parent.AutoFilterMode = False

            .SpecialCells(xlCellTypeFormulas).ClearContents ' clear cell with formulas
            If .Range("A1").Value = "dummy header" Then .Range("A1").ClearContents ' remove any "dummy" header
        End With
    End With

    Application.ScreenUpdating = True

End Sub