Sub CopyData2Lists()
   Dim sh As Worksheet, r1 As Long, r2 As Long, r1e As Long, rg As Range
   On Error Resume Next:  r1e = Cells(Rows.Count, 1).End(xlUp).Row + 1
   For Each sh In Sheets: With sh
     Application.StatusBar = .Name
     If .Index > Sheets("Тендеры").Index Then
       r2 = .Cells(Rows.Count, 1).End(xlUp).Row
       r1 = 8
       If r2 > 7 Then
         r1 = WorksheetFunction.Match(.Cells(r2, 1), [a:a], 0): If Err.Number > 0 Then Err.Clear Else r1 = r1 + 1
       End If
       Set rg = Range(Cells(r1, 5), Cells(r1e, 8)).Find(.Name, LookIn:=xlValues, lookat:=xlPart, MatchCase:=True)
       If Not rg Is Nothing Then
         Do
           r2 = r2 + 1: rg.EntireRow.Copy Destination:=.Cells(r2, 1): Application.StatusBar = .Name & "  R:" & r2
           Set rg = Range(Cells(rg.Row + 1, 5), Cells(r1e, 8)).Find(.Name, LookIn:=xlValues, lookat:=xlPart, MatchCase:=True)
         Loop While Not rg Is Nothing
       End If
     End If
   End With:  Next
   On Error GoTo 0: Application.StatusBar = False
End Sub