Moving Cells within a spreadsheet

[tferrier18]

Hey Guys,

I've never really done much VBA so I'm in desperate need of some help
I've got a spreadsheet with a lot of data in it that I would like moved to one column.

Currently I have 1000 rows of data in D,E,F,G,H,I,J,K,L,M,N & O

I would like D1 moved to B5, D2 moved to B27, D3 moved to B49 (All the way until D1000 has been moved to B22005.

Data in E1 should be moved to B6, E2 to B28 and so on.
F1 to B7, F2 is B29 and so on.
G1 to B8, G2 to B30 and so on.
H1 to B9, H2 to B31 and so on.
I1 to B10, I2 to B32 and so on.
J1 to B11, J2 to B33 and so on.
K1 to B12, K2 to B34 and so on.
L1 to B13, L2 to B35 and so on.
M1 to B14, M2 to B36 and so on.
N1 to B15, N2 to B37 and so on.
O1 to B16, O2 to B38 and so on.

The pattern is moving each cell of info from D1 to B5 and D2 is moved 22 rows after B5 (B27)

So basically I'm trying to move 12 columns into one column (B)

Any help on this would really be appreciated

Thank you in advance

[Bob Phillips]

Turn on the macro recorder, do those steps in Excel. You have your code.

[tferrier18]

Including repeating the steps for all 1000 rows though?

[Bob Phillips]

No, select the whole column and do it in blocks.

[GTO]

Howdy ya'll,

Apologies if I am misunderstanding, but it looked to me as you are wanting to transpose ea row in the (hang on, I ran out of fingers...) 12 columns, along w/putting some empty rows between ea block in destination.

If so, in a junk copy of your wb, try:

Sub exa()
Dim wks As Worksheet
Dim lRowToCopy As Long, lRowToPaste As Long
    
    lRowToPaste = 5
    '// Change to suit, like:   Set wks = ThisWorkbook.Worksheets("Sheet1")         //
    Set wks = ActiveSheet
    
    Application.ScreenUpdating = False
    With wks
        For lRowToCopy = 1 To 1000
            .Range(.Cells(lRowToCopy, "D"), .Cells(lRowToCopy, "O")).Copy
            .Cells(lRowToPaste, "B").PasteSpecial Paste:=xlValues, Operation:=xlNone, _
                                                   SkipBlanks:=False, Transpose:=True
            lRowToPaste = lRowToPaste + 22
        Next
        .Range("D1:O1000").ClearContents
    End With
    Application.ScreenUpdating = True
End Sub

Hope that helps,

Mark