Cutting sets # of contiguous columns and appending to bottom of new range.

[CMSREPORTS]

I have a set of horizontal data that needs to be realigned into a veridical list. Each group of 6 columns needs to be cut and appended to the bottom of the first 6 columns.
The process is then repeated for the next 6 columns and appended to the new last row.

I can do this manually, but it is terribly tedious and I am wondering if there is a better way to do it with a loop.

Sub Realign()

Set ws1 = ThisWorkbook.Sheets("priceListComparison")
ws1.Select

Last_Original = ws1.Cells(1048576, 2).End(xlUp).Row

'Move end date data (G-L)
Last_r1 = ws1.Cells(1048576, 2).End(xlUp).Row
Range("G2:L" & Last_Original).Cut
Range("A" & Last_r1 + 1).Select
ActiveSheet.Paste

'Move Nbr_Amt data (M-R)
Last_r2 = ws1.Cells(1048576, 2).End(xlUp).Row
Range("M2:R" & Last_Original).Cut
Range("A" & Last_r2 + 1).Select
ActiveSheet.Paste

'Move print_indicator data (S-X)
Last_r3 = ws1.Cells(1048576, 2).End(xlUp).Row
Range("S2:X" & Last_Original).Cut
Range("A" & Last_r3 + 1).Select
ActiveSheet.Paste

Etc...

The remaining groups of 6 are ...

Y - AD
AE-AJ,
AQ-AV
AW-BB
BC-BH
BI-BN
BO-BT
BU-BZ
CA-CF
CG-CL
CM-CR
CS-CX
CY-DD
DE-DJ
DK-DP
DQ-DV
DW-EB

 

[kevin9999]

Try the following on a copy of your workbook.

Option Explicit
Sub CMSREPORTS()
    Application.ScreenUpdating = False
    Dim ws1 As Worksheet
    Set ws1 = Worksheets("priceListComparison")
    Dim ArrIn(), arrOut(), arr()
    Dim i As Long, j As Long, LCol As Long, LRow As Long, LRowS As Long
    Dim rw As Long, col As Long, r As Long, totR As Long, nRng As Long
    
    LCol = ws1.Cells.Find("*", , xlFormulas, , 2, 2).Column
    LRowS = ws1.Cells.Find("*", , xlFormulas, , 1, 2).Row
    nRng = (LCol - 12) / 6
    
    'Fill the input array
    ReDim ArrIn(1 To nRng)
    With ws1
        j = 13
        For i = 1 To nRng
            LRow = ws1.Range(ws1.Cells(1, j), ws1.Cells(LRowS, j)).Find("*", , xlFormulas, , 1, 2).Row
            ArrIn(i) = ws1.Cells(2, j).Resize(LRow - 1, 6)
            totR = totR + UBound(ArrIn(i), 1)
            j = j + 6
        Next i
    End With
    
    'Fill the output array
    ReDim arrOut(1 To totR, 1 To 6)
    r = 1
    For i = 1 To nRng
        arr = ArrIn(i)
        For rw = 1 To UBound(arr, 1)
            For col = 1 To UBound(arr, 2)
                arrOut(r, col) = arr(rw, col)
            Next col
            r = r + 1
        Next rw
    Next i
    
    'Put the output array under A2
    ws1.Range("A2").Resize(totR, 6).Value = arrOut
    Application.ScreenUpdating = True
    
    'Uncomment the next line if you want to clear columns M-EB after they've been moved
    'ws1.Range("M:EB").EntireColumn.ClearContents
    
End Sub

 

[CMSREPORTS]

Thank you so much. It was very close on the first run. But it did exactly what I wanted it to do, and very quickly.

I encountered two problems:
1) the information that was in the first 6 columns was over written when the data was transferred
2) the data from G-L did not end up in the final set, only the data from the set beginning with M onward.

Made two modifications, and it worked out.

1) Changed J=13 to J=1 and the data maintained, but did not do the full data set. 'Line 17
2) Changed nRng = (LCol - 0) / 6 'Line 12

I appreciate your help.

 

[kevin9999]

Thank you so much. It was very close on the first run. But it did exactly what I wanted it to do, and very quickly.

I encountered two problems:
1) the information that was in the first 6 columns was over written when the data was transferred
2) the data from G-L did not end up in the final set, only the data from the set beginning with M onward.

Made two modifications, and it worked out.

1) Changed J=13 to J=1 and the data maintained, but did not do the full data set. 'Line 17
2) Changed nRng = (LCol - 0) / 6 'Line 12

I appreciate your help.

Glad you got it sorted, and thanks for the feedback