Macro ou formule de recherche de lignes.

Sub test()
Dim BaseA As Range, BaseB As Range, i&, j&, Nb&, temp
With Sheets("feuil1")
Set BaseA = .Range("A1:E" & .Range("A" & Rows.Count).End(xlUp).Row)
Set BaseB = .Range("F1:H" & .Range("F" & Rows.Count).End(xlUp).Row)
    For i = 1 To BaseB.Rows.Count
    temp = ""
        For j = 1 To BaseA.Rows.Count
            Nb = .Evaluate("SUM(COUNTIF(" & BaseA.Rows(j).Address & "," & BaseB.Rows(i).Address & "))")
            If Nb = 3 Then
                temp = temp & " " & j
                Dim tabl()
                ReDim Preserve tabl(1 To BaseA.Rows.Count)
                tabl(i) = temp
            End If
        Next j
    Next i
    .[I1].Resize(BaseA.Rows.Count) = Application.Transpose(tabl)
 End With
End Sub

Sub test2()
Dim BaseA As Range, BaseB As Range, i&, j&, k&, Nb&, temp
With Sheets("feuil1")
Set BaseA = .Range("A1:E" & .Range("A" & Rows.Count).End(xlUp).Row)
Set BaseB = .Range("F1:H" & .Range("F" & Rows.Count).End(xlUp).Row)
    For i = 1 To BaseB.Rows.Count
        k = 1
        For j = 1 To BaseA.Rows.Count
        
            Nb = .Evaluate("SUM(COUNTIF(" & BaseA.Rows(j).Address & "," & BaseB.Rows(i).Address & "))")
            If Nb = 3 Then
                Dim tabl()
                ReDim Preserve tabl(1 To BaseA.Rows.Count, 1 To BaseA.Columns.Count)
                tabl(i, k) = j: k = k + 1
            End If
        Next j
    Next i
    .[I1].Resize(UBound(tabl), UBound(tabl, 2)) = tabl
 End With
End Sub