Vb, how to copy values & repeat to next 50 cells [Closed]

Report
Posts
10
Registration date
Saturday July 3, 2010
Status
Member
Last seen
May 5, 2016
-
Posts
2675
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 5, 2020
-
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

Posts
2675
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 5, 2020
448
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

Subscribe To Our Newsletter!

The Best of CCM in Your Inbox

Subscribe To Our Newsletter!