Vb, how to copy values & repeat to next 50 cells

Closed
weenie
Posts
10
Registration date
Saturday July 3, 2010
Status
Member
Last seen
May 5, 2016
- Jan 16, 2014 at 11:59 PM
TrowaD
Posts
2880
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
May 2, 2022
- Jan 20, 2014 at 10:56 AM
Hello,
Need help writing code @ step C & D
I am:
A) copying values in E1-E4 & transposing values
B) to Col. A next available empty row (obviously Col B-D at these rows will be empty also)
C) need it to copy (same info from step B) down next 50 rows
D) How to loop steps A-C

I don't want to hard code the Col & Row because I will be clearing contents in E1-E4 & moving over next set of data and repeating above steps A-C. I have data in Col E-Col EY.

Example
45
oven
0
500

NOW transposed
45 oven 0 500

??how do I repeat the transposed data to next 50 rows??

I have this code so far:
Range("E1:E4").Select
Selection.Copy
Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False

????Need the repeat to 50 rows????

Range("E1:E4").Select
Selection.ClearContents
Range("F1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Cut
Range("E1").Select
ActiveSheet.Paste

??How do I loop Above???

Thanks,
Weenie

1 reply

TrowaD
Posts
2880
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
May 2, 2022
510
Jan 20, 2014 at 10:56 AM
Hi Weenie,

The following code will loop through all used columns starting at E.
4 Rows of the respective column will be copied and transposed to the first available row in column A.
The 4 rows from the respective column will be cleared.
The transposed data will be repeated 49 times (covering row 2-51 for first batch).

Sub RunMe()
Dim lCol, x, y As Integer

lCol = Range("E1").End(xlToRight).Column
x = 2
y = 51

For Each cell In Range(Cells(1, "E"), Cells(1, lCol))
Range(cell, cell.Offset(3, 0)).Copy
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Range(cell, cell.Offset(3, 0)).ClearContents
Range(Cells(x, "A"), Cells(x, "D")).Copy

Do
Range("A" & x + 1).PasteSpecial
x = x + 1
Loop Until x = y

y = y + 50
x = x + 1
Next cell

Application.CutCopyMode = False

End Sub

Best regards,
Trowa
0