VBA to copy rows multiple times based on the cell value

[Zetori]

Hi

I have huge list of values, about 40 000 values in column B starting from row 5. I need to copy each row multiple times based on the cell value (B2).

List is now like:

0001
0002
0003

If the cell value in B2 is 4, every row in column B starting from row 5 is copied 4 times and the result would look like:

0001
0001
0001
0001
0002
0002
0002
0002
0003
0003
0003
0003

I really appreciate if someone have time to take a look at this problem.

Thank You!

 

[VoG]

Try

Sub test()
Dim LR As Long, i As Long
Dim N As Long
N = Range("B2").Value
LR = Range("B" & Rows.Count).End(xlUp).Row
For i = LR To 5 Step -1
    Range("B" & i).Copy
    Range("B" & i).Resize(N - 1).Insert shift:=xlShiftDown
Next i
Application.CutCopyMode = False
End Sub

 

[Zetori]

Try

Sub test()
Dim LR As Long, i As Long
Dim N As Long
N = Range("B2").Value
LR = Range("B" & Rows.Count).End(xlUp).Row
For i = LR To 5 Step -1
    Range("B" & i).Copy
    Range("B" & i).Resize(N - 1).Insert shift:=xlShiftDown
Next i
Application.CutCopyMode = False
End Sub

Wow! that was fast! and worked like a dream. Thank you so much!

 

[wdp74]

Wow! that was fast! and worked like a dream. Thank you so much!

Try

Sub test()
Dim LR As Long, i As Long
Dim N As Long
N = Range("B2").Value
LR = Range("B" & Rows.Count).End(xlUp).Row
For i = LR To 5 Step -1
    Range("B" & i).Copy
    Range("B" & i).Resize(N - 1).Insert shift:=xlShiftDown
Next i
Application.CutCopyMode = False
End Sub

I know is an old thread but this was exactly what I needed except it keeps adding a blank space between each set.