I need to move the data from certain cells in multiple positions (different columns & rows) into a s

[objRobertMitchell]

I need to move (cut & paste ) the data from certain cells in multiple
positions (different columns & rows) into a single row and then repeat
the same process over-and-over again. The procedure should continue to
drill-down the worksheet, Approx. 6000 rows) until these referenced
cells (relative to their position) become empty. The data in Cell B3
would need to go into Cell F11, data in Cell B4 into Cell G11, B5 into
cell J11 ...data in Cell B6 into Cell H11, B7 into Cell I11, and then
move data in Cell F8 into E11... finally move down 54 rows/positions
and repeat this process for the rest of the relative cells.
See below: existing position of data and final position.

Since a picture says a thousand words:

Existing positions of data: B3,B4,B5,B6,B7,F8

Final positions of data after moved: F11,G11,J11,H11,I11,E11

Example:

| A | B | C | D | E | F | G | H | I | J |
______|_____________________________________________________________
Row 1 |
Row 2 |
Row 3 | Cust
Row 4 | Prod
Row 5 | Desc
Row 6 | Date
Row 7 | Rev#
Row 8 | Sp.G
Row 9 |
Row 10|
Row 11| Sp.G Cust Prod Date Rev# Desc


|
| * Skip Down 54 spaces (Relative to Starting Position),(B3).
|
| * Repeat the (Cut & Paste or Move) operation.
|
|
| Existing positions of data: B57,B58,B59,B60,B61,F62
|
| Final positions of data after moved: F65,G65,J65,H65,I65,E65
V

| A | B | C | D | E | F | G | H | I | J |
_______|_____________________________________________________________
Row 54 |
Row 56 |
Row 57 | Cust
Row 58 | Prod
Row 59 | Desc
Row 60 | Date
Row 61 | Rev#
Row 62 | Sp.G
Row 63 |
Row 64 |
Row 65 | Sp.G Cust Prod Date Rev# Desc


* Repeat the (Cut & Paste or Move) operation until the cells to
copy become empty/null or Approx. Row 6000.

I will then proceed to move this data into an access database.
I thought an action query to do this would be even more
difficult for me to try and figure out. However, I'm still
open to any suggestions.

Thanks,
Robert

 

[Dave Peterson]

Try this against a copy of your worksheet--just in case:

Option Explicit
Sub testme()

'B3 , B4, B5, B6, B7, F8
'F11,G11,J11,H11,I11,E11

'B57,B58,B59,B60,B61,F62
'F65,G65,J65,H65,I65,E65

Dim wks As Worksheet
Dim iRow As Long
Dim LastRow As Long
Dim FirstRow As Long

Set wks = Worksheets("sheet1")

With wks
FirstRow = 3
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row

For iRow = FirstRow To LastRow Step 54
.Cells(iRow, "B").Resize(5, 1).Copy
.Cells(iRow + 8, "F").PasteSpecial Transpose:=True

.Cells(iRow + 5, "F").Copy _
Destination:=.Cells(iRow + 8, "E")
Next iRow
End With

End Sub

 

[objRobertMitchell]

Try this against a copy of your worksheet--just in case:

Option Explicit
Sub testme()

'B3 , B4, B5, B6, B7, F8
'F11,G11,J11,H11,I11,E11

'B57,B58,B59,B60,B61,F62
'F65,G65,J65,H65,I65,E65

Dim wks As Worksheet
Dim iRow As Long
Dim LastRow As Long
Dim FirstRow As Long

Set wks = Worksheets("sheet1")

With wks
FirstRow = 3
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row

For iRow = FirstRow To LastRow Step 54
.Cells(iRow, "B").Resize(5, 1).Copy
.Cells(iRow + 8, "F").PasteSpecial Transpose:=True

.Cells(iRow + 5, "F").Copy _
Destination:=.Cells(iRow + 8, "E")
Next iRow
End With

End Sub

'
************************************************************************
Dave,

Thanks a MILLION! ....

What would have probably taken me more than 45 minutes...

....took the computer about 1.5 seconds, thanks for your help.

Robert

 

[Tom Ogilvy]

Sub ProcessData()
r = 3
do while cells(r,2) <> ""
cells(r,2).Resize(6,1).copy
cells(r+8,"F").PasteSpecial xlPasteAll, Transpose:=True
cells(r,2).Resize(6,1).ClearContents
r = r + 54
Loop
end sub

 

[objRobertMitchell]

Sub ProcessData()
r = 3
do while cells(r,2) <> ""
cells(r,2).Resize(6,1).copy
cells(r+8,"F").PasteSpecial xlPasteAll, Transpose:=True
cells(r,2).Resize(6,1).ClearContents
r = r + 54
Loop
end sub

Thanks Guys!

There will always be more than one way to skin a cat.

.....As proven during one of my Anatomy & Physiology Labs!

....Sorry Kitty!

Robert M.

 

[Tom Ogilvy]

You might want to have a look at your data. For me, Dave's (and my
original) didn't work properly. This seemed to:

'E11 F11 G11 H11 I11 J11
'f8 B3 B4 B6 B7 B5
Sub ProcessData()
r = 3
Do While Cells(r, 2) <> ""
Cells(r + 8, "F") = Cells(r, 2)
Cells(r + 8, "G") = Cells(r + 1, 2)
Cells(r + 8, "J") = Cells(r + 2, 2)
Cells(r + 8, "H") = Cells(r + 3, 2)
Cells(r + 8, "I") = Cells(r + 4, 2)
Cells(r + 8, "E") = Cells(r + 5, 6)
Cells(r, 2).Resize(5, 1).ClearContents
Cells(r + 5, 6).ClearContents
r = r + 54
Loop
End Sub

 

[Tom Ogilvy]

No, this isn't correct and I don't believe Dave's is either. See my second
post.

 

[Dave Peterson]

Tom,

You're right. I read the order as more natural (a simple transpose).

Here's hoping that the OP comes back or doesn't really care about the order
<bg>. (Maybe he just moved the columns after running either of the macros????)

 

[Tom Ogilvy]

At least you picked up the column F variation - I missed it all the first
time because the first couple appeared in order allowing me to immediatley
jump to that infamous place called conclusions.

 

[Dave Peterson]

But that infamous place is nice, warm and bright. There are never any problems
there.

Rosy skies all around!