Echt gewoon het idee afmaken dat Randolph Potter begon….
Voor de goede orde, ik denk niet dat je dit ooit zou kunnen bedenken door op te nemen. Macro opname is een goede manier om vertrouwd te raken met het Excel Object Model, maar niet een erg goede manier om herbruikbare functies te schrijven.
Option Explicit
'A simple test that copies every 7th row from the active sheet to a new sheet.
Sub SimpleTest()
Dim r As Range
Dim ws As Worksheet
Set r = GetEveryNthRow(7)
If Not r Is Nothing Then
Set ws = Worksheets.Add(Before:=Sheets(1))
r.Copy ws.Range("A1")
Else
MsgBox "Nothing came back from GetEveryNthRow"
End If
Set ws = Nothing
Set r = Nothing
End Sub
'
Function GetEveryNthRow(ByVal NthRow As Long) As Range
Dim keepRows As Range
Dim r As Range
If NthRow > 0 Then
Set keepRows = Rows(1)
For Each r In ActiveSheet.UsedRange.Rows
If (r.Row Mod NthRow) = 0 Then
Set keepRows = Union(keepRows, Rows(r.Row))
End If
Next r
Set GetEveryNthRow = keepRows
Else
MsgBox "The row multiple provided must be greater than 0"
End If
Set keepRows = Nothing
End Function