Sub Sobrat_Data()
Dim FoundDate As Range
Dim ListName As Date
Dim FirstDate As String
Dim i As Long
Dim n As Integer
Dim iLastRow As Long
Dim iSh As Worksheet
Dim nSh As Worksheet
 For i = 1 To ThisWorkbook.Worksheets.Count
     Set iSh = ThisWorkbook.Worksheets(i)
   ListName = iSh.Name
     With Workbooks("1")
       For n = 1 To .Worksheets.Count
         Set nSh = .Worksheets(n)
           With nSh
             Set FoundDate = .Columns(6).Find(ListName, , xlFormulas, xlWhole)
               If Not FoundDate Is Nothing Then
                FirstDate = FoundDate.Address
                 Do
                   iLastRow = iSh.Cells(Rows.Count, 2).End(xlUp).Row + 1
                     iSh.Cells(iLastRow, 2) = .Cells(FoundDate.Row, 1) 'имя
                     iSh.Cells(iLastRow, 3) = .Cells(FoundDate.Row, 2) 'адрес
                     iSh.Cells(iLastRow, 4) = .Cells(FoundDate.Row, 3) 'дом
                     iSh.Cells(iLastRow, 5) = .Cells(FoundDate.Row, 4) 'кв
                     iSh.Cells(iLastRow, 6) = .Cells(FoundDate.Row, 5) 'сумма платежа
                   Set FoundDate = .Columns(6).FindNext(FoundDate)
                 Loop While FoundDate.Address <> FirstDate
               Else
                  MsgBox "Нет такой даты в столбце F"
               End If
           End With
       Next
     End With
 Next
End Sub