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

我有一个10张以上的工作簿，每个工作簿都有数十万个值（125k工作表1，240k工作表2，400k工作表3等等）。我正在修整工作表，每个工作表保持每千分之一的点数。

我一直无法得到代码来完成第一张表上的数据修剪。 代码运行了一个多小时，没有完成第一张表。 我也尝试过使用较小的数据集（5张〜1000点），但是macros只能在第一张纸上成功修剪点。 其他表没有修改

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

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 

这个特定任务的代码被插入在这个问题中find的代码的修改版本*信用给那些最初写这些代码的人

问题： Excel VBA性能 – 100万行 – 在1分钟内删除包含值的行

这里是他的代码中使用的助手函数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生成一个testing集的一个漂亮的小代码：

 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 

生成一个testing集并将其复制到几张纸后，我运行了以下代码的修改版本

代码的主体是由用户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性能 – 100万行 – 在1分钟内删除包含值的行

---

下面的代码（模块2）设置testing数据 – 10个工作表中的3000万个公式（3个全列）

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

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

---

第一单元 – 主要部分

---

 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 – 设置testing数据子和辅助程序

---

 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

我认为你最大的performance是你经常删除，而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

使用SpreadSheetGuru的定时器我在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应用程序而不是一个荣耀的macros（所有这些与工作表的不断交互使我头晕）。 既然你保持每1000（？）行的数据，那么你应该：

1. 声明一个arrayX（1050，ColumnsCount_toKeep）作为Variant

2. 阅读，使用一个简单的For …接下来，工作表的每1000年的数据行进入数组（通过UsedRange.Rows.Count或类似的东西）

3. 在一个命令中删除工作表中的所有数据

4. 将arrayX写入现在为空的工作表中

5. 说“完成！” （这将在你的第三至第四口气）

我希望你有足够的VBA技能来解决这个问题。 这个论坛的精神阻碍了我为你写作，抱歉…祝你好运！