Kopier bestemte rækker over i nyt ark

Sub Copy_differencen()
    Dim RW As Long, Data1 As Variant, Uddata() As Variant
    Dim intI As Long, intJ As Long, Synlig As Boolean
    Dim FraArk As String, TilArk As String
    Synlig = False    '
    FraArk = "Ark1" ' arket der kopieres fra
    TilArk = "Ark2" ' arket der kopieres til
    If Application.DisplayStatusBar Then
        Synlig = True
    Else
        Synlig = False
        Application.DisplayStatusBar = True
    End If

    ThisWorkbook.Sheets(TilArk).Rows("2:65536").ClearContents
    Application.ScreenUpdating = False
    Application.Calculation = xlManual

    RW = ThisWorkbook.Worksheets(FraArk).Range("E65536").End(xlUp).Row
    Data1 = ThisWorkbook.Sheets(FraArk).Range("E1:E" & RW)

    For intI = 1 To UBound(Data1)
        If Data1(intI, 1) <> 0 Then
            intJ = ThisWorkbook.Sheets(TilArk).Range("E65536").End(xlUp).Row + 1
            ThisWorkbook.Sheets(FraArk).Range("A" & intI).EntireRow.Copy ThisWorkbook.Sheets(TilArk).Range("A" & intJ)
        End If
        Application.StatusBar = " Kikker på række " & intI & " af " & RW & " heraf kopieret " & intJ - 3
    Next
    Application.StatusBar = ""
    MsgBox "Færdig"
    If Not Synlig Then Application.DisplayStatusBar = False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Application.StatusBar = " Kikker på række " & intI & " af " & RW & " heraf kopieret " & intJ - 3

skal være

Application.StatusBar = " Kikker på række " & intI & " af " & RW & " heraf kopieret " & intJ - 1

Kabbak> Den virker næsten fint - Jeg har ændret så den skal være forskellig fra "" (tom). Hvordan får jeg får jeg markoen til at starte i række 1 i stedet for række 2? Jeg har ændret ThisWorkbook.Sheets(TilArk).Rows("2:65536").ClearContents
til ThisWorkbook.Sheets(TilArk).Rows("1:65536").ClearContents - Det virker ikke!

Sub Copy_differencen()
    Dim RW As Long, Data1 As Variant, Uddata() As Variant
    Dim intI As Long, intJ As Long, Synlig As Boolean
    Dim FraArk As String, TilArk As String
    Synlig = False    '
    FraArk = "Ark1" ' arket der kopieres fra
    TilArk = "Ark2" ' arket der kopieres til
    If Application.DisplayStatusBar Then
        Synlig = True
    Else
        Synlig = False
        Application.DisplayStatusBar = True
    End If

    ThisWorkbook.Sheets(TilArk).Rows("1:65536").ClearContents
    Application.ScreenUpdating = False
    Application.Calculation = xlManual

    RW = ThisWorkbook.Worksheets(FraArk).Range("E65536").End(xlUp).Row
    Data1 = ThisWorkbook.Sheets(FraArk).Range("E1:E" & RW)

    For intI = 1 To UBound(Data1)
        If Data1(intI, 1) <> 0 Then
            intJ = ThisWorkbook.Sheets(TilArk).Range("E65536").End(xlUp).Row + 1
            If ThisWorkbook.Sheets(TilArk).Range("E1") = "" Then intJ = 1
            ThisWorkbook.Sheets(FraArk).Range("A" & intI).EntireRow.Copy ThisWorkbook.Sheets(TilArk).Range("A" & intJ)
        End If
       
        Application.StatusBar = " Kikker på række " & intI & " af " & RW & " heraf kopieret " & intJ
    Next
    Application.StatusBar = ""
    MsgBox "Færdig"
    If Not Synlig Then Application.DisplayStatusBar = False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Det virker - Tak!
Smid et svar!

et svar ;-))