Indsættelse af rækker i excelark

Dim ræk As Long, sidsteRæk, tæller As Byte, antal As Byte
Dim ræk2 As Long
Public Sub indsætRækker()
    ræk2 = 2
    sidsteRæk = ActiveCell.SpecialCells(xlLastCell).Row
   
    For ræk = 2 To sidsteRæk
        antal = Range("C" & ræk)
        For tæller = 1 To antal
            With ActiveWorkbook.Sheets("Ark2")
                .Cells(ræk2, 1) = Cells(ræk, 1)
                .Cells(ræk2, 2) = Cells(ræk, 2)
                .Cells(ræk2, 3) = tæller
                ræk2 = ræk2 + 1
            End With
        Next tæller
    Next ræk
   
End Sub

Fandt selv en løsning hvor jeg bruger Do While løkker:

Dim Mat As String 'material "denne er NR i eksemplet"
Dim CS As String "denne er gruppe i eksemplet"
Dim n As Integer 'group counter "denne er tæller i eksemplet"
Dim i As Integer
Dim j As Integer
Dim x As Integer

Sub insertrows()

Do While j <= 6082
i = Cells(2 + j, 2)
n = 1

Do While n <= i
Cells(2 + x, 7) = Cells(2 + j, 1)
Cells(2 + x, 8) = n
Cells(2 + x, 9) = Cells(2 + j, 3)
Cells(2 + x, 10) = Cells(2 + j, 4)
Cells(2 + x, 11) = Cells(2 + j, 5)
n = n + 1
x = x + 1
Loop

j = j + 1
i = Cells(2 + j, 2)
Loop

End Sub

Ved ikke om det matcher helt med mit første forsimplede eksempel, men det kører til gengæld lidt langsomt. Har ca 5000 rækker der bliver til 33000..

Er det hurtigere at bruge For next?

Prøv at slå skærmopdateringen fra inden loopet..

Application.screenupdating = false

prøv denne

Public Sub LavRK()
    Dim Data As Variant, DataUd As Variant, X As Long, I As Long, Y As Long
    Data = Worksheets("Ark1").Range("A1").CurrentRegion' ret til dit ark
    X = 1
    For I = 2 To UBound(Data, 1)
        X = X * Data(I, 3)
    Next
    ReDim DataUd(X, UBound(Data, 2) - 1)
    DataUd(0, 0) = Data(1, 1)
    DataUd(0, 1) = Data(1, 2)
    DataUd(0, 2) = Data(1, 3)
    Y = 1
   
    For I = 2 To UBound(Data, 1)
        For X = 1 To Data(I, 3)
            DataUd(Y, 0) = Data(I, 1)
            DataUd(Y, 1) = Data(I, 2)
            DataUd(Y, 2) = X
            Y = Y + 1
        Next
    Next
' ret næste til dit ark
    Worksheets("Ark2").Range("A1").Resize(UBound(DataUd, 1) + 1, UBound(DataUd, 2) + 1) = DataUd
End Sub

Ved at slå skærmopdateringen fra gik det væsentligt hurtigere :-)
Ved ikke om jeg kommer til at bruge denne makro igen, men den sparede mig da for en del copy/paste arbejde.