Vba loop

Hi All,


New to coding, looking for a way to do a loop I guess is the best way.


I have column H with 7,000 lines of ID's.

I need to copy and paste those lines 6 times.

Then I sort them and on column O write numbers 1-6 . The loop is for those 7000 Ids to have one number each.

Samething on column N (this time with text)

End when there is no more text on column H.

Example:

H N O
ID1 A 1
ID1 B 2
ID1 C 3
ID1 D 4
ID1 E 5
ID1 F 6
ID2 A 1
ID2 B 2
ID2 C 3
ID2 D 4
ID2 E 5
ID2 F 6
ID3 A 1
ID3 B 2
ID3 C 3
ID3 D 4
ID3 E 5
ID3 F 6



I would like to thank anyone who can help in advance! I'm desperate! Thanks!

Hi,

You can use For Next loop to copy paste your data repeatedly. Then on column O you can apply countif formula by locking the first cell instead of whole range.
It will work perfectly. For column N, you can use Vlookup or directly replace the numbers, with your text

Maybe:

Sub rafaruiz123()
Dim i As Long
Dim x As Long
Dim y As String
For i = Range("H" & Rows.Count).End(3).Row To 2 Step -1
y = Range("H" & i).Value
Rows(i).Copy
x = 6
    Do Until x = 0
        Cells(i, "A").EntireRow.Insert
        Cells(i + 1, "O") = x
        Cells(i + 1, "H") = y
        Select Case x
            Case Is = 1
                Cells(i + 1, "N") = "A"
            Case Is = 2
                Cells(i + 1, "N") = "B"
            Case Is = 3
                Cells(i + 1, "N") = "C"
            Case Is = 4
                Cells(i + 1, "N") = "D"
            Case Is = 5
                Cells(i + 1, "N") = "E"
            Case Is = 6
                Cells(i + 1, "N") = "F"
        End Select
        x = x - 1
    Loop
Next i
Range("H2:H" & Range("H" & Rows.Count).End(3).Row).SpecialCells(4).EntireRow.Delete
End Sub

Wow thanks for the propmtly response, however the code is giving out a space betwen every six lines. I tired puting do until x=1 insted of 0 but gives the samething one space between each ID. Also it takes quite a while not sure if its because of the spaces.

Its looking greattt but has that small problem.
How can we fix that.

Thanks again!

Bhavsarankit can you explain your reasoning with a few lines of code if possible! I would be really appreciate it.

Thanks again John but unforgtunately is not working! It's still giving up a blank space between them.

Also takes like 4 seconds for every line and i have over 50,000 lines!

Try:

Sub rafaruiz123()
Dim i As Long
Dim x As Long
Dim y As String
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
For i = Range("H" & Rows.Count).End(3).Row To 2 Step -1
y = Range("H" & i).Value
Rows(i).Copy
x = 6
    Do Until x = 0
        Cells(i, "A").EntireRow.Insert
        Cells(i + 1, "O") = x
        Cells(i + 1, "H") = y
        Select Case x
            Case Is = 1
                Cells(i + 1, "N") = "A"
            Case Is = 2
                Cells(i + 1, "N") = "B"
            Case Is = 3
                Cells(i + 1, "N") = "C"
            Case Is = 4
                Cells(i + 1, "N") = "D"
            Case Is = 5
                Cells(i + 1, "N") = "E"
            Case Is = 6
                Cells(i + 1, "N") = "F"
        End Select
        x = x - 1
    Loop
Next i
Range("H2:H" & Range("H" & Rows.Count).End(3).Row).SpecialCells(4).EntireRow.Delete
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
End Sub

The red input should take out the blanks? I did on some dummy data I made up for testing?