Loop Move Columns

[exKW258]

I need a loop to move many columns (in pairs) into 4 columns. I have row descriptions in column E:F and the values in I:J. The values can go out to columns GY:GZ. I need to move columns E:F to A:B and the number values to C:D. So all data will be moved to columns A-B-C-D. Here is the code I have. I added the separation lines to make it easier to see what's going on.

    Range("E2:F2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Offset(1, 0).Select
    ActiveSheet.Paste
 '------------------------   
    Range("I2:J2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("C2").Select
    Selection.End(xlDown).Offset(1, 0).Select
    ActiveSheet.Paste
 '-------------------------   
    Range("E2:F2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Offset(1, 0).Select
    ActiveSheet.Paste
 '-------------------------   
    Range("K2:L2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("C2").Select
    Selection.End(xlDown).Offset(1, 0).Select
    ActiveSheet.Paste

The code is written for each column that has data to be moved. This makes the module extremely long and cumbersome. Does anyone know how to loop this function? Thanks.

 

[onlyadrafter]

Hello,

Sub COPY_OVER()
    For MY_COLS = 5 To Cells(1, Columns.Count).End(xlToLeft).Column Step 8
        MY_LAST_ROW = Cells(Rows.Count, MY_COLS + 1).End(xlUp).Row
        Range(Cells(1, MY_COLS), Cells(MY_LAST_ROW, MY_COLS + 1)).Copy
        Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteAll)
        MY_LAST_ROW = Cells(Rows.Count, MY_COLS + 5).End(xlUp).Row
        Range(Cells(1, MY_COLS + 4), Cells(MY_LAST_ROW, MY_COLS + 5)).Copy
        Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteAll)
    Next MY_COLS
End Sub

I have assumed your first row descriptions are in E:F, M:N (i.e. spaced at 7 columns apart), and the values are I:J, Q:R (i.e. spaced at 7 columns apart). So there are always two columns between descriptions and values.

 

[exKW258]

Thanks onlyadrafter. And welcome back! I greatly appreciate your help. We're off to a good start. My spreadsheet looks like this...


Col1 Col2 Acct Amt Acct Amount Account Amount Account Amount
H1001 Descrip1 11111 $142.00 2222 $1,012.00 3333 $2,012.00 4444 $3,012.00
H1002 Descrip2 11111 $123.00 2222 $1,123.00 3333 $2,123.00 4444 $3,123.00
H1003 Descrip3 11111 $132.00 2222 $1,012.00 3333 $2,012.00 4444 $3,012.00
H1004 Descrip4 11111 $124.00 2222 $1,124.00 3333 $2,124.00 4444 $3,124.00


I then add 4 columns to the far left and proceed to move the data. Col1 and Col2 will repeat for every instance where paired columns of Acct and Amt exist. The final result looks like this...

Col1 Col2 Account Amount
H1001 Descrip1 11111 $142.00
H1002 Descrip2 11111 $123.00
H1003 Descrip3 11111 $132.00
H1004 Descrip4 11111 $124.00
H1001 Descrip1 2222 $1,012.00
H1002 Descrip2 2222 $1,123.00
H1003 Descrip3 2222 $1,012.00
H1004 Descrip4 2222 $1,124.00
H1001 Descrip1 3333 $2,012.00
H1002 Descrip2 3333 $2,123.00
H1003 Descrip3 3333 $2,012.00
H1004 Descrip4 3333 $2,124.00
H1001 Descrip1 4444 $3,012.00
H1002 Descrip2 4444 $3,123.00
H1003 Descrip3 4444 $3,012.00
H1004 Descrip4 4444 $3,014.00


I hope this make sense.

 

[Rick Rothstein]

Does this macro do what you want...

Sub RearrangeData()
  Dim X As Long, LastRow As Long, LastCol As Long, Repeats As Long
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
  Repeats = (LastCol - 2) / 2
  Columns("A").Resize(, 4).Insert
  Range("A1").Offset(, 4).Resize(, 4).Copy Range("A1")
  Range("E2").Resize(LastRow - 1, 2).Copy Range("A2").Resize(Repeats * (LastRow - 1), 2)
  For X = 1 To Repeats '7 To LastCol + 4 Step 4
    Cells(2, 2 * X + 5).Resize(LastRow - 1, 2).Copy Cells(4 * X - 2, 3)
  Next
End Sub