试试这个代码：

Option Explicit
Sub SubDataExtraction()
    
    'Declarations.
    Dim DblIndex As Double
    Dim VarResult() As Variant
    Dim RngResult As Range
    Dim RngCell As Range
    Dim RngData As Range
    Dim StrSearchWord01 As String
    Dim StrSearchWord02 As String
    Dim StrSearchWord03 As String
    
    'Settings.
    Set RngData = Range(Range("B2"), Range("B" & Range("B" & Rows.Count).End(xlUp).Row))
    Set RngResult = Range("E2")
    StrSearchWord01 = "Main"
    StrSearchWord02 = "Sub"
    StrSearchWord03 = "animal"
    ReDim VarResult(1 To RngData.Rows.Count, 1 To 3)
    
    'Covering each cell of RngData.
    For Each RngCell In RngData
        
        'Checking if RngCell contains both StrSearchWord01 and StrSearchWord02.
        If InStr(1, RngCell.Value2, StrSearchWord01) <> 0 And InStr(1, RngCell.Value2, StrSearchWord02) <> 0 Then
            
            'Setting DblIndex for the next row of results.
            DblIndex = DblIndex + 1
            
            'Reporting the values in VarResult (column 1 and 2).
            VarResult(DblIndex, 1) = RngCell.Offset(0, -1).Value2
            VarResult(DblIndex, 2) = RngCell.Value2
            
        End If
        
        'Checking if RngCell contains StrSearchWord03 and if VarResult hasn't already a value in the first and third column.
        If InStr(1, RngCell.Value2, StrSearchWord03) <> 0 And _
           VarResult(Excel.WorksheetFunction.Max(DblIndex, 1), 3) = "" And _
           VarResult(Excel.WorksheetFunction.Max(DblIndex, 1), 1) <> "" _
           Then
            
            'Reporting the value in VarResult (column 3).
            VarResult(DblIndex, 3) = RngCell.Value2
            
        End If
        
    Next
    
    'Reporting the result in RngResult properly expanded.
    RngResult.Resize(DblIndex, UBound(VarResult, 2)).Value2 = VarResult
    
End Sub

Sub test2()

Dim x As Long, Line As Long, SubLine As Long

x = 1
For Line = 2 To Range("B" & Rows.Count).End(xlUp).Row

    If InStr(1, Range("B" & Line), "Main") <> 0 And InStr(1, Range("B" & Line), "Sub") <> 0 Then
        
        SubLine = Line
        Do Until Range("A" & SubLine) <> Range("A" & SubLine + 1)
            SubLine = SubLine + 1
        Loop
        
        x = x + 1
        Range("E" & x) = Range("A" & Line)
        Range("F" & x) = Range("B" & Line)
        Range("G" & x) = Range("B" & SubLine)
    End If
Next

End Sub