VBA - 删除每张工作簿上的每 N 行（每张工作表 100k+ 值）

Question

我有一个包含 10 多张工作表的工作簿，每张都有数十万个值（125k sheet1、240k sheet 2、400k sheet 3，等等）表。

我无法获取代码来完成第一张纸上的数据修剪。代码已经运行了一个多小时而没有完成第一张工作表。我也尝试过使用较小的数据集（5 张纸中约 1000 个点），但宏只能成功修剪第一张纸上的点。其他表没有修改

下面是我用来删除行间隔的代码；这是我能找到的删除行的最可定制的方式（这正是我正在寻找的：定制/简单性

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

这个特定任务的代码被插入到这个问题中找到的代码的修改版本中*感谢最初编写它们的人

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

这是 Paul bica 在他的代码中使用的辅助函数

    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

由 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

生成测试集并将其复制到多个工作表后，我运行了以下代码的修改版本

代码主体由用户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

我将上面的代码修改如下

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

我不确定如何进一步修改此代码以及时在工作簿中的每个工作表上运行。

提前感谢您的任何指导

Answer 1

我认为您最大的性能锚点是您删除的频率如此之高，而 Excel 不得不移动如此多的数据。您可能会考虑先清除内容和/或使用 UNION 函数一次性删除所有内容。下面是如何编写这两种方法的示例：

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

Answer 2

使用The SpreadSheetGuru's Timer，我在 13.53 秒内从 4 个工作表中总共删除了 1,599,992 个。

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

Answer 3

您可以使用与链接中相同的方法

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

---

下面的代码（模块 2）设置测试数据 - 10 个工作表中的 3000 万个公式（3 个完整列）

模块 1 中的子循环遍历所有工作表和

• 隐藏 1K 行集
• 将可见行复制到新工作表
• 删除初始工作表

---

模块 1 - 主子

---

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

---

模块 2 - 设置测试数据子程序和辅助程序

---

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