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 VBA Performance - 1 million rows - Delete rows containing a value, in less than 1 min

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

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

隐藏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

Answer 2

我认为你最大的性能支柱是你经常删除而且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 3

使用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 4

首先，您应该编写一个VBA应用程序而不是一个美化的宏（所有这些与工作表的持续交互让我头晕目眩）。由于您要保留每个1000（？）行的数据，因此您应该：

声明一个arrayX（1050，ColumnsCount_toKeep）As Variant
阅读，使用简单的For ...接下来，工作表将每1000个数据行放入数组中（通过UsedRange.Rows.Count或类似的东西）
在一个命令中删除工作表中的所有数据
将arrayX写入now-empty工作表
说＆＃34;完成！＆＃34; （这将是你的第3至第4次呼吸）

我希望你有足够的VBA技能来解决这个问题。这个论坛的精神阻止了我为你写的，对不起......祝你好运！

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

4 个答案: