PDA

View Full Version : Moving Cells within a spreadsheet



tferrier18
08-15-2010, 11:26 PM
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
08-16-2010, 01:00 AM
Turn on the macro recorder, do those steps in Excel. You have your code.

tferrier18
08-16-2010, 01:35 AM
Including repeating the steps for all 1000 rows though?

Bob Phillips
08-16-2010, 02:06 AM
No, select the whole column and do it in blocks.

GTO
08-16-2010, 02:17 AM
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