Slette rækker periodisk

Foehåbentlig ikke hver anden i hele arket :-)
kan mindre ikke gøre det ?

Hver anden ville være rigtig fint, men hver tredie kan også gøre det. Casen er et excelark med over 60.000 rækker med data og jeg vil gerne fjerne hver anden række. Dette er der måske ikke en "hurtig" måde at gøre på?

Nu kender jeg ikke dit layout så dette er en test du kan prøve på en kopi af din fil
Koden indsætter formler i Q2:Q60000 og forudsætter at du kun har data til venstre herfor - ellers må du lige skrive tilbage

Sub Hver2()

Range("Q2:Q60000").Formula = "=MOD(ROW(),2)"
Range("Q2:Q60000").Copy
Range("Q2:Q60000").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

Range("A2:Q60000").Sort Key1:=Range("Q2"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

Range("Q1") = "test"
Range("Q1:Q60000").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="0"
Range("Q2:Q60000").SpecialCells(xlCellTypeVisible).EntireRow.Delete
Range("Q2").Select

End Sub

Alternativ

Sub Hver2()

Range("Q2:Q60000").Formula = "=MOD(ROW(),2)"
Range("Q2:Q60000").Copy
Range("Q2:Q60000").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

Range("A2:Q60000").Sort Key1:=Range("Q2"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

x = Range("Q2:Q60000").Find(0, LookIn:=xlValues).Row
Range("Q" & x & ":Q60000").EntireRow.Delete
Range("Q2:Q60000") = ""
Range("Q2").Select

End Sub

Mange tak, det vil jeg prøve :)

Hvordan går det ?