Improve Shift Data Up Macro

Question

Please help me with a little code that I have. I am hoping we can tweak it a little. I have a sheet that has columns grouped by 4 and separated by 2 blank columns. The data goes far to the right and is only 600 rows deep. The idea is to move all scattered data to the top leaving no more blank cells as a result. The code below is effective and very fast. But will only work for the first group of 4 columns from A1.

I really need to make this work because all other code I've tried for this just takes way, way too long.

I'm no expert in VBA but I can only go as far as the code here. How can we modify it to make it move all data to the top for all the columns in a bigger range?

Sub ShiftDataUp()

Dim y, z

y = Range("a1:p39"): iii = 1
ReDim z(1 To UBound(y, 1), 1 To UBound(y, 2))
For i = 1 To UBound(y)
If Not IsEmpty(y(i, 1)) Then
For ii = 1 To UBound(y, 2)
z(iii, ii) = y(i, ii)
Next
iii = iii + 1
End If
Next
Range("a1:p39").ClearContents
For i = 1 To UBound(y, 1)
For ii = 1 To UBound(y, 2)
Cells(i, ii) = z(i, ii)
Next
Next

End Sub

Answer 1

Try sorting out the blank rows.

Dim a As Long, b As Long

With Worksheets("sheet1")
    b = .Cells.Find(What:="*", After:=.Cells(1), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    For a = 1 To b Step 6
        with .Range(.Cells(1, a), .Cells(.Rows.Count, a + 3).End(xlUp))
            .Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, _
                        Key2:=.Columns(2), Order2:=xlAscending, _
                        Orientation:=xlTopToBottom, Header:=xlNo
        End With
    Next a
End With