[gr8styl]

Καλημέρα καλησπέρα.
Φίλε Σωκράτη αν έχω καταλάβει σωστά το ζητούμενό σου,
ο παρακάτω κώδικας αντιγράφει τα στοιχεία από όλα τα φύλλα του βιβλίου στο φύλλο Sheet1.
Δοκίμασέ το και πες μας αν έγινε.
Ελπίζω να καταφέρεις να τον προσαρμόσεις παραπέρα αν χρειαστεί.

Φιλικά
Θανάσης

Option Explicit

Sub test()
Dim DstSheet As String
Dim Sht As Worksheet
Dim R As Long, FirstRow As Long, LastRow As Long
Dim Answer

DstSheet = "Sheet1"

Answer = MsgBox("Do you want to clear " & DstSheet & " ?", vbYesNo)
If Answer = vbYes Then Sheets(DstSheet).Cells.Clear
Application.ScreenUpdating = False
For Each Sht In ThisWorkbook.Sheets
    If Sht.Name <> DstSheet Then
        LastRow = Sheets(DstSheet).Cells(Rows.Count, "A").End(xlUp).Row
        Sheets(DstSheet).Cells(LastRow + 1, "A").Value = "'" & Sht.Name
        Sht.Range("D5").Copy Destination:=Sheets(DstSheet).Cells(LastRow + 1, "B")
        
        For R = 5 To 27 'copy  each cell from range H5:H27 to dstSheet column C
            LastRow = Sheets(DstSheet).Cells(Rows.Count, "D").End(xlUp).Row
            If Sht.Range("H" & R).Value <> "" Then
                Sht.Cells(R, "H").Copy Destination:=Sheets(DstSheet).Cells(LastRow + 1, "C")
                Application.CutCopyMode = False
                Sht.Range("I" & R & ":AB" & R).Copy 'range I5:AB5 to dstSheet column D
                Sheets(DstSheet).Cells(LastRow + 1, "D").PasteSpecial Paste:=xlPasteAll, _
                        Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                
                FirstRow = Sheets(DstSheet).Cells(Rows.Count, "C").End(xlUp).Row
                LastRow = Sheets(DstSheet).Cells(Rows.Count, "D").End(xlUp).Row
                Sheets(DstSheet).Cells(FirstRow, "C").Copy Destination:= _
                        Range("C" & FirstRow & ":C" & LastRow) 'fill down column C
            End If
        Next R
        FirstRow = Sheets(DstSheet).Cells(Rows.Count, "A").End(xlUp).Row
        LastRow = Sheets(DstSheet).Cells(Rows.Count, "D").End(xlUp).Row
        Sheets(DstSheet).Range("A" & FirstRow & ":B" & FirstRow).Copy Destination:= _
            Range("A" & FirstRow & ":B" & LastRow) 'fill down columns A and B
    End If
Next
Application.ScreenUpdating = True
Sheets(DstSheet).Activate
Sheets(DstSheet).Range("A1").Select
MsgBox "Data copied to " & DstSheet & " worksheet.", vbOKOnly
End Sub