Sub test()
Dim a, b(), i As Long, j As Long, n As Long, cpt As Long, maxcpt As Long
a = Range("a1").CurrentRegion
ReDim b(1 To UBound(a, 1) - 2, 1 To UBound(a, 2))
For i = 2 To UBound(a, 2)
n = 0: cpt = 0
For j = 3 To UBound(a, 1)
n = n + 1
If a(j, i) <> "" Then
cpt = cpt + 1
If cpt > maxcpt Then
b(j - 1 - n, 1) = "Comp" & j - 1 - n
End If
b(j - 1 - n, i) = a(j, 1)
n = n - 1
End If
Next
If maxcpt < cpt Then maxcpt = cpt
Next
Range("a" & Rows.Count).End(xlUp)(3).Resize(maxcpt, UBound(b, 2)) = b
End Sub