VBA - Delete Every Nth Row On Each Sheet Of Workbook (100k+ values per sheet)

Question

I have a workbook with 10+ sheets, with hundreds of thousands of values in each (125k sheet1, 240k sheet 2, 400k sheet 3, etc.) I am trimming down the sheets by keeping every thousandth or so point in each sheet.

I have been unable to get the code to finish trimming data on the first sheet. The code has run for well over an hour without finishing the first sheet. I've tried with smaller data sets as well (~1000 points in 5 sheets), but the macro only successfully trims points on the first sheet. The other sheets are not modified

Below is the code I'm using to delete an interval of rows; it is the most customizable way to delete rows I could find (which is exactly what i'm looking for: customization/simplicity

lastRow = Application.ActiveSheet.UsedRange.Rows.Count    

For i = 2 To lastRow Step 1        'Interval of rows to delete
     Range(Rows(i), Rows(i + 997)).Delete Shift:=xlUp
Next i

The code for this specific task is inserted into a modified version of a codes found in this question *credit to those who originally wrote them

Question: Excel VBA Performance - 1 million rows - Delete rows containing a value, in less than 1 min

Here's Helper Functions paul bica used in his code

    Public Sub FastWB(Optional ByVal opt As Boolean = True)
      With Application
        .Calculation = IIf(opt, xlCalculationManual, xlCalculationAutomatic)
        .DisplayAlerts = Not opt
        .DisplayStatusBar = Not opt
        .EnableAnimations = Not opt
        .EnableEvents = Not opt
        .ScreenUpdating = Not opt
      End With
      FastWS , opt
    End Sub

    Public Sub FastWS(Optional ByVal ws As Worksheet = Nothing, _
    Optional ByVal opt As Boolean = True)
      If ws Is Nothing Then
        For Each ws In Application.ActiveWorkbook.Sheets
            EnableWS ws, opt
        Next
      Else
            EnableWS ws, opt
      End If
    End Sub

    Private Sub EnableWS(ByVal ws As Worksheet, ByVal opt As Boolean)
      With ws
        .DisplayPageBreaks = False
        .EnableCalculation = Not opt
        .EnableFormatConditionsCalculation = Not opt
        .EnablePivotTable = Not opt
        End With
    End Sub

A nifty little code for generating a test set by marko2049:

Sub DevelopTest()
    Dim index As Long
    FastWB True
    ActiveSheet.UsedRange.Clear
    For index = 1 To 1000000 '1 million test
        ActiveSheet.Cells(index, 1).Value = index
        If (index Mod 10) = 0 Then
            ActiveSheet.Cells(index, 2).Value = "Test String"
        Else
            ActiveSheet.Cells(index, 2).Value = "Blah Blah Blah"
        End If
    Next index
    Application.StatusBar = ""
    FastWB False
End Sub

After generating a test set and copying it to several sheets, I ran a modified version of the code below

The main body of the code was made by user marko5049

Sub DeleteRowFast()
    Dim curWorksheet As Worksheet 'Current worksheet vairable

    Dim rangeSelection As Range   'Selected range
    Dim startBadVals As Long      'Start of the unwanted values
    Dim endBadVals As Long        'End of the unwanted values
    Dim strtTime As Double        'Timer variable
    Dim lastRow As Long           'Last Row variable
    Dim lastColumn As Long        'Last column variable
    Dim indexCell As Range        'Index range start
    Dim sortRange As Range        'The range which the sort is applied to
    Dim currRow As Range          'Current Row index for the for loop
    Dim cell As Range             'Current cell for use in the for loop

    On Error GoTo Err
        Set rangeSelection = Application.InputBox("Select the (N=) range to be checked", "Get Range", Type:=8)    'Get the desired range from the user
        Err.Clear

    M1 = MsgBox("This is recommended for large files (50,000 or more entries)", vbYesNo, "Enable Fast Workbook?") 'Prompt the user with an option to enable Fast Workbook, roughly 150% performace gains... Recommended for incredibly large files
    Select Case M1
        Case vbYes
            FastWB True  'Enable fast workbook
        Case vbNo
            FastWB False 'Disable fast workbook
    End Select

    strtTime = Timer     'Begin the timer

    Set curWorksheet = ActiveSheet
    lastRow = CLng(rangeSelection.SpecialCells(xlCellTypeLastCell).Row)
    lastColumn = curWorksheet.Cells(1, 16384).End(xlToLeft).Column

    Set indexCell = curWorksheet.Cells(1, 1)

    On Error Resume Next

    If rangeSelection.Rows.Count > 1 Then 'Check if there is anything to do

        lastVisRow = rangeSelection.Rows.Count

        Set sortRange = curWorksheet.Range(indexCell, curWorksheet.Cells(curWorksheet.Rows(lastRow).Row, 16384).End(xlToLeft)) 'Set the sort range

        sortRange.Sort Key1:=rangeSelection.Cells(1, 1), Order1:=xlAscending, Header:=xlNo 'Sort by values, lowest to highest

        startBadVals = rangeSelection.Find(What:="Test String", LookAt:=xlWhole, MatchCase:=False).Row
        endBadVals = rangeSelection.Find(What:="Test String", LookAt:=xlWhole, SearchDirection:=xlPrevious, MatchCase:=False).Row

        curWorksheet.Range(curWorksheet.Rows(startBadVals), curWorksheet.Rows(endBadVals)).EntireRow.Delete 'Delete uneeded rows, deleteing in continuous range blocks is quick than seperated or individual deletions.

        sortRange.Sort Key1:=indexCell, Order1:=xlAscending, Header:=xlNo 'Sort by index instead of values, lowest to highest
    End If

    Application.StatusBar = ""                    'Reset the status bar

    FastWB False                                  'Disable fast workbook

    MsgBox CStr(Round(Timer - strtTime, 2)) & "s" 'Display duration of task

Err:
    Exit Sub

End Sub

I've modified the above code as follows

Sub DeleteRowFastMod()

    Dim lastRow As Long
    Dim i As Long
    Dim ws As Worksheet
    Dim wb As Workbook
    Set wb = Application.ActiveWorkbook

    On Error GoTo Err
            'Get the desired range from the user
        Err.Clear

    FastWB True  'Enable fast workbook


    strtTime = Timer     'Begin the timer


    On Error Resume Next


For Each ws In wb.Worksheets(1)         'Loop through sheets in workbook 
    ws.Activate
    lastRow = Application.ActiveSheet.UsedRange.Rows.Count

    If lastRow > 1 Then 'Check if there is anything to do

       For i = 2 To lastRow Step 1        'Interval of rows to delete
           Range(Rows(i), Rows(i + 997)).Delete Shift:=xlUp
       Next i
    End If
Next

    Application.StatusBar = ""                    'Reset the status bar

    FastWB False                                  'Disable fast workbook

    MsgBox CStr(Round(Timer - strtTime, 2)) & "s" 'Display duration of task

Err:
    Exit Sub

End Sub

I am not sure how to further modify this code to run on each sheet in the workbook in a timely manner.

Thanks in advance for any guidance

you have not described what you are trying to do. `trimming down the sheets by keeping every thousandth or so point in each sheet.` is meaningless — jsotola, Oct 03 '17 at 23:49
No offense meant, but you did not understand the code that you tried to modify. If you want to understand it, I would recommend stepping through the code and seeing what it is doing. If you want to use the same approach as before, what you want to do is make a helper column that puts in the original row number, a second helper column that says if the row is a multiple of 1000 (put "Y" if so), sort by the second helper column, delete ONE RANGE of rows (the ones with "N" in the second helper column), and the resort the data using the first helper column. — OpiesDad, Oct 03 '17 at 23:57
Another option would be to simply create another worksheet and use worksheet functions to grab every 1000th row, then delete the original worksheet. This would probably be a little slower than the method you tried originally, but it would be pretty fast too. — OpiesDad, Oct 03 '17 at 23:58
Also, this will only work on 1 worksheet because you used the line `For Each ws In wb.Worksheets(1)`. Note that `wb.Worksheets(1)` is only 1 worksheet. You want to use the same thing they did in the code you tried to modify, `For Each ws In wb.Sheets` — OpiesDad, Oct 04 '17 at 00:01

paul bica · Accepted Answer · 2017-10-04T15:54:41.610

You could use the same method as in the link

Excel VBA Performance - 1 million rows - Delete rows containing a value, in less than 1 min

The code bellow (Module 2) sets up test data - 30 million formulas (3 full columns) in 10 Worksheets

The sub in Module 1 loops through all sheets and

hides 1K rows sets
copies visible rows to a new sheet
deletes the initial sheet

Module 1 - Main Sub

Option Explicit

Public Sub TrimLargeData()    'Time: 12.531 sec
    Const TRIM_SZ = 1000
    Dim t As Double, wb As Workbook, ws As Worksheet
    Dim lr As Long, r As Long, newWs As Worksheet, done As Collection

    t = Timer:  Set wb = ThisWorkbook
    FastWB True

    Set done = New Collection
    For Each ws In wb.Worksheets
        done.Add ws
    Next

    For Each ws In done
        lr = ws.UsedRange.Rows.Count

        For r = 1 To lr Step TRIM_SZ
           If r >= lr - (TRIM_SZ + 1) Then
                ws.Range(ws.Cells(r + 1, 1), ws.Cells(lr - 1, 1)).EntireRow.Hidden = True
                Exit For
           End If
           ws.Range(ws.Cells(r + 1, 1), ws.Cells(r + TRIM_SZ - 1, 1)).EntireRow.Hidden = True
        Next

        Set newWs = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        newWs.Name = Left("Trimmed " & ws.Name, 30)
        ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy newWs.Cells(1)
        ws.Delete
    Next
    FastWB False:   Debug.Print "Time: " & Format(Timer - t, "0.000") & " sec"
End Sub

Module 2 - setup test data subs, and helper procedures

Option Explicit

'generates 30 million formulas (3 full columns) on 10 Worksheets, in about 1 min

Public Sub MakeTestData()
    Dim t As Double, ur As Range, ws As Worksheet

    t = Timer
    FastWB True
        FormatCells
        MakeWorksheets

        With ThisWorkbook
            Set ws = .Worksheets(1)
            Set ur = ws.Range("A1:C" & ws.Rows.Count)
            ur.Formula = "=Address(Row(), Column(), 4)"
            .Worksheets.FillAcrossSheets ur
        End With
    FastWB False
    Debug.Print "Time: " & Format(Timer - t, "0.000") & " sec"
End Sub

Private Sub FormatCells()
    With ThisWorkbook.Worksheets(1).Cells
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .IndentLevel = 0
        .MergeCells = False
    End With
End Sub

Private Sub MakeWorksheets()
    Dim ws As Worksheet, i As Long, wsName As Long

    With ThisWorkbook
        If .Worksheets.Count > 1 Then
            For Each ws In .Worksheets
                If ws.Index <> 1 Then ws.Delete
            Next
        End If
        For i = 1 To 10
            wsName = .Worksheets.Count
            .Worksheets.Add(After:=.Worksheets(wsName)).Name = wsName
        Next
    End With
End Sub

Public Sub FastWB(Optional ByVal opt As Boolean = True)
  With Application
    .Calculation = IIf(opt, xlCalculationManual, xlCalculationAutomatic)
    .DisplayAlerts = Not opt
    .DisplayStatusBar = Not opt
    .EnableAnimations = Not opt
    .EnableEvents = Not opt
    .ScreenUpdating = Not opt
  End With
  FastWS , opt
End Sub

Public Sub FastWS(Optional ByVal ws As Worksheet = Nothing, _
Optional ByVal opt As Boolean = True)
  If ws Is Nothing Then
    For Each ws In Application.ActiveWorkbook.Sheets
        EnableWS ws, opt
    Next
  Else
        EnableWS ws, opt
  End If
End Sub

Private Sub EnableWS(ByVal ws As Worksheet, ByVal opt As Boolean)
  With ws
    .DisplayPageBreaks = False
    .EnableCalculation = Not opt
    .EnableFormatConditionsCalculation = Not opt
    .EnablePivotTable = Not opt
    End With
End Sub

Hi Paul. This macro seems to work well, except that it does not delete the last group of 1k values in the range. How should this be corrected? — ClockworkNemo, Oct 04 '17 at 14:01
I updated the main Sub to remove the last group, not including the last row — paul bica, Oct 04 '17 at 15:25

score 0 · Answer 2 · answered Oct 04 '17 at 01:04

I think your biggest performance anchor is that you're deleting so frequently and Excel is having to move around so much data. You might consider clearing contents first and/or using a UNION function to do the delete all in one effort. So here's an example of how both approaches would be written:

Sub UnionExample()
Dim deleteRNG As Range

'You need one start statement that is not a union.
Set deleteRNG = Rows(2)

'Now you can start a loop or use some method to include members in your delete range
Set deleteRNG = Union(deleteRNG, Rows(4))

'when finished creating the delete range, clear contents (it's helped my performance)
deleteRNG.ClearContents


'then do your full delete
deleteRNG.Delete shift:=xlUp

End Sub

score 0 · Answer 3 · 2017-10-04T15:19:17.667

Using The SpreadSheetGuru's Timer I removed a total of 1,599,992 from 4 Worksheets in 13.53 seconds.

Sub ProcessWorksheets()
    Dim ws As Worksheet

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    For Each ws In ThisWorkbook.Worksheets
        KeepNthRows ws.UsedRange, 2, 1000
    Next

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

Sub KeepNthRows(Target As Range, FirstRow As Long, NthStep As Long)
    Dim data As Variant, results As Variant
    Dim x1 As Long, x2 As Long, y As Long

    If Target.Rows.Count < 2 Then Exit Sub

    FirstRow = FirstRow - 1                           'Adjustment needed for using Range.Offset
    data = Target.Offset(FirstRow).Value

    ReDim results(1 To UBound(data, 1), 1 To UBound(data, 2))

    For x1 = FirstRow To UBound(data, 1) Step NthStep
        x2 = x2 + 1
        For y = 1 To UBound(data, 2)
            results(x2, y) = data(x1, y)
        Next
    Next

    Target.Offset(FirstRow).Value = results
End Sub

I tried running Sub ProcessWorksheets, but get Run-time error 13 on the ReDim line. I'm not exactly sure how to fix that — ClockworkNemo, Oct 04 '17 at 11:29
I updated my code. The error occurred when the Worksheets' UsedRange had less than 2 rows — , Oct 04 '17 at 15:20

VBA - Delete Every Nth Row On Each Sheet Of Workbook (100k+ values per sheet)

3 Answers3