Sub FindAndFound()
Dim arr(), a&, b%, aa As Range, sh As Worksheet, cWB As Workbook, oWB As Workbook, bb As Range
Set cWB = ThisWorkbook: Set oWB = Workbooks("Книга2.xlsx")
For Each aa In Intersect(cWB.Sheets(1).[a2].CurrentRegion, cWB.Sheets(1).Columns(1))
  b = 1
  For Each sh In oWB.Worksheets
    Set bb = sh.UsedRange.Find(What:=aa, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlRows)
    If bb Is Nothing Then Exit For
    aa.Offset(, b) = sh.Name: aa.Offset(, b + 1) = bb.Offset(, 1): b = b + 2
  Next
Next
End Sub