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

CMSREPORTS

New Member
Joined
Nov 29, 2018
Messages
10
Office Version
  1. 2013
Platform
  1. Windows
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.

VBA Code:
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
 

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.
Try the following on a copy of your workbook.

VBA Code:
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
 
Upvote 1
Solution
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.
 
Upvote 0
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 👍 😀
 
Upvote 0

Forum statistics

Threads
1,213,482
Messages
6,113,913
Members
448,532
Latest member
9Kimo3

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top