Поиск в книге, по названию листа другой. Excel

Sub report ()
X=1
Y=1
WbPath=ThisWorkbook.Path & "\"
 
'Цикл присваивания названия книг по порядку
 
For i=2 To 31
Xi=xi+1
WbName=xi
On Error Resume Next
Workbooks.Open(wbPath &wbName)
If Err=0 Then
 
'Вот здесь должен быть цикл поиска по названию листа, копировании строки, и переход на следующий лист
 
Else: y=y+1
End If
Next i
MsgBox "Пропущено " & y & " документов."
 
'Закрываем все книги кроме той, из которой запущен макрос
 
Dim wb as workbook
For Each wb in Workbooks
If not wb is ThisWorkbook Then
If wb.windows(1).Visible Then wb.close
End If
Next wb
End Sub

Sub add()
    Dim con As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim path As String
    Dim i As Integer, j As Integer, k As Integer
    
    path = ThisWorkbook.path & "\"
    For i = 1 To 31
        con.Open ("Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & path & i & ".xls; Extended Properties=""Excel 8.0;HDR=No;IMEX=1""")
        rst.Open ("select * from [Лист1$]"), con
        For j = 0 To 69
            With ThisWorkbook.Sheets(rst.Fields(0).Value)
                For k = 1 To rst.Fields.Count - 1
                    .Cells(i, k + 1).Value = rst.Fields(k).Value
                Next k
            End With
            rst.MoveNext
        Next j
        
        rst.Close
        
        con.Close
    Next i
End Sub

Sub add()
    Dim con As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim path As String
    Dim i As Integer, j As Integer, k As Integer
    
    path = ThisWorkbook.path & "\"
    For i = 1 To 31
        con.Open ("Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & path & i & ".xls; Extended Properties=""Excel 8.0;HDR=No;IMEX=1""")
        rst.Open ("select * from [Лист1$]"), con
        
        Do While Not rst.EOF
            With ThisWorkbook.Sheets(rst.Fields(0).Value)
                For k = 1 To rst.Fields.Count - 1
                    .Cells(i, k + 1).Value = rst.Fields(k).Value
                Next k
            End With
            rst.MoveNext
        Loop
        
        rst.Close
        
        con.Close
    Next i
End Sub

Sub bb()
Dim i&, j&, c As Range, wb As Workbook
On Error Resume Next
Application.ScreenUpdating = False
For i = 1 To 31
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & i & ".xlsx")
  If Err Then
    Err.Clear
  Else
    For j = 1 To ThisWorkbook.Worksheets.Count
      Set c = wb.Worksheets(1).Columns(2).Find(ThisWorkbook.Worksheets(j).Name, , xlValues, xlWhole)
      If Not c Is Nothing Then
        c.Offset(, 1).Resize(, 4).Copy ThisWorkbook.Worksheets(j).Cells(i + 1, 2)
      End If
    Next
    wb.Close 0
  End If
Next
Application.ScreenUpdating = True
End Sub

Sub test()
    Dim con As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim i As Integer, j As Integer
    For i = 1 To 31
        On Error Resume Next
        con.Open ("Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & ThisWorkbook.path & "\" & i & ".xlsx; Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1""")
        If Err = 0 Then
            rst.Open ("select * from [Ежедневный отчет$]"), con
            Do While Not rst.EOF
                With ThisWorkbook.Sheets(rst.Fields(1).Value)
                    For j = 2 To rst.Fields.Count - 1
                        .Cells(i + 1, j).Value = rst.Fields(j).Value
                    Next j
                End With
                rst.MoveNext
            Loop
            rst.Close
            con.Close
          Else
            Err = 0
        End If
    Next i
End Sub