[ChrisGT7]

Δοκίμασε τον παρακάτω κώδικα αν σε καλύπτει:

Option Explicit

Sub METAFORA()
    Dim SC As Byte
    Dim R1 As Long, R2 As Long
    Dim C1 As Long, C2 As Long
    
    Application.ScreenUpdating = False
    Range("DC3:DF" & Rows.Count).ClearContents
    
    For SC = 1 To 4
        R2 = 3
        For C1 = 2 + SC * 21 To 21 + SC * 21
            R1 = 3
            Do
                If Cells(R1, C1).Value = "" Then
                    R1 = 0
                Else
                    Cells(R2, Evaluate("MATCH(""Section ""&" & SC & ",2:2,0)")).Value = Cells(R1, C1).Value
                    R1 = R1 + 1
                    R2 = R2 + 1
                End If
            Loop While R1 > 0
        Next
    Next
    
    Application.ScreenUpdating = True
End Sub

Θεωρώ πως τα δεδομένα στις στήλες είναι συνεχόμενα (το ένα κάτω από το άλλο) και δεν παρεμβάλονται μεταξύ τους κενά κελιά.