Sub Перенос()

   Dim i As Integer, shts As Integer, rw As Integer, drw As Integer
   
   shts = ThisWorkbook.Sheets.Count
   For i = 2 To shts - 1
      With Worksheets(i)
         drw = .Columns(4).Find(what:="Водитель", LookIn:=xlValues, lookat:=xlWhole).Row + 1
         Do Until .Cells(drw, 1).Value = ""
            rw = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Cells(rw, 1).Value = .Cells(1, 1).Value
            .Range(.Cells(drw, 1), .Cells(drw, 8)).Copy
            Cells(rw, 2).PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False
            drw = drw + 1
         Loop
      End With
   Next i
   ActiveSheet.Range(Cells(1, 1), Cells(rw, 9)).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9), Header:=xlYes

End Sub