Kopiering af rækker

Fandt en løsning hvor jeg kopierer det ned i række 6000 og efterfølgende:

'KOPIER RÆKKER
    Dim LSearchRow As Integer
    Dim LCopyToRow As Integer

   
    'Start search in row 3
    LSearchRow = 3

    'Start copying data to row 2 in Sheet2 (row counter variable)
    LCopyToRow = 6000

    While Len(Range("A" & CStr(LSearchRow)).Value) > 0

        'If value in column A <> "", copy entire row to Sheet2
        If Range("A" & CStr(LSearchRow)).Value <> "" Then

            'Select row in Sheet1 to copy
            Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
            Selection.Copy

            'Paste row into Sheet1 in next row
            Sheets("Ark1").Select
            Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
            ActiveSheet.Paste

            'Move counter to next row
            LCopyToRow = LCopyToRow + 1

            'Go back to Sheet1 to continue searching
            Sheets("Ark1").Select

        End If

        LSearchRow = LSearchRow + 1
       
        Wend

    'Position on cell A3
    Application.CutCopyMode = False
    Range("A3").Select