Sub TZ()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim Sht As Worksheet
iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To iLastRow
Set Sht = ThisWorkbook.Worksheets("" & Cells(i, "A") & "")
With Sht
iLR = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
Range("A" & i & ":D" & i).Copy .Cells(iLR, "A")
End With
Next
End Sub

Sub TZ()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim FirstRow As Long
Dim Sht As Worksheet
    iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    FirstRow = 10
For i = 2 To iLastRow
If SheetExists("" & Cells(i, "A") & "") Then
    Set Sht = ThisWorkbook.Worksheets("" & Cells(i, "A") & "")
  With Sht
    iLR = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
      If iLR < 10 Then iLR = FirstRow
    Range("A" & i & ":D" & i).Copy .Cells(iLR, "A")
  End With
Else
   MsgBox "В книге нет листа с именем: " & Cells(i, "A")
End If
Next
End Sub

Function SheetExists(WSName) As Boolean
  On Error Resume Next
  SheetExists = Sheets(WSName).Name = WSName
  On Error GoTo 0
End Function