我需要一个更快的Excel VBAmacros,删除列A中的每一行0

现在,我正在使用下面的macros来删​​除列A中的每一行0。问题是它太慢了。 花了大约三十秒来完成两千行的工作,但是我需要一个macros来处理30万行。 当前macros冻结了我的电脑多行。 我已经尝试了这个网站上的第一个五个解决scheme,没有运气: http : //www.dummies.com/software/microsoft-office/excel/10-ways-to-speed-up-your-macros/

Sub Loop_Example() Dim Firstrow As Long Dim Lastrow As Long Dim Lrow As Long Dim CalcMode As Long Dim ViewMode As Long With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With 'We use the ActiveSheet but you can replace this with 'Sheets("MySheet")if you want With ActiveSheet 'We select the sheet so we can change the window view .Select 'If you are in Page Break Preview Or Page Layout view go 'back to normal view, we do this for speed ViewMode = ActiveWindow.View ActiveWindow.View = xlNormalView 'Turn off Page Breaks, we do this for speed .DisplayPageBreaks = False 'Set the first and last row to loop through Firstrow = .UsedRange.Cells(1).Row Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row 'We loop from Lastrow to Firstrow (bottom to top) For Lrow = Lastrow To Firstrow Step -1 'We check the values in the A column in this example With .Cells(Lrow, "A") If Not IsError(.Value) Then If .Value = "0" Then .EntireRow.Delete 'This will delete each row with the Value "ron" 'in Column A, case sensitive. End If End With Next Lrow End With ActiveWindow.View = ViewMode With Application .ScreenUpdating = True .Calculation = CalcMode End With End Sub 

我不能评论这是否是最快的方法,但是对于这些答案,实际代码可能是最短的:

 'get number of cells in A column Dim x as long: x = WorksheetFunction.CountA(ActiveSheet.Range("A:A")) 'AutoFilter to pick up only zeroes ActiveSheet.Range("$A$1:$Z" & x).AutoFilter Field:=1, Criteria1:=0 'delete what is currently filtered ActiveSheet.Rows("2:" & x).Delete Shift:= xlUp 

编辑:

 ActiveSheet.Range("$A$1:$Z" & x).AutoFilter 

– 加上这个结束后closures自动filter

这里的自动filter按列A(A:Z中的字段1)进行sorting,并查找零(标准:= 0) – 可能需要适应您的目的,但它很简单

注意:这需要300000+行需要一段时间 – 我有一个例程,每两周一次从这样的数据集中取出大约20万行。 这可能听起来很疯狂,除非我只是使用这些数据在数据透视表中进行汇总 – 一旦刷新了数据,大部分数据就可以进行了。

不要阅读1 – 1。 一次全部删除。

 Sub Loop_Example() Dim Firstrow As Long Dim Lastrow As Long Dim Lrow As Long Dim CalcMode As Long Dim ViewMode As Long Dim Data As Variant Dim DelRange As Range With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With 'We use the ActiveSheet but you can replace this with 'Sheets("MySheet")if you want With ActiveSheet 'We select the sheet so we can change the window view .Select 'If you are in Page Break Preview Or Page Layout view go 'back to normal view, we do this for speed ViewMode = ActiveWindow.View ActiveWindow.View = xlNormalView 'Turn off Page Breaks, we do this for speed .DisplayPageBreaks = False 'Set the first and last row to loop through Firstrow = .UsedRange.Cells(1).Row Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row Data = .Range("A1:A" & Lastrow) 'We loop from Lastrow to Firstrow (bottom to top) For Lrow = Lastrow To Firstrow Step -1 If Not IsError(Data(Lrow, 1)) And Not IsEmpty(Data(Lrow, 1)) Then If Data(Lrow, 1) = 0 Then If DelRange Is Nothing Then Set DelRange = .Rows(Lrow) Else Set DelRange = Union(DelRange, .Rows(Lrow)) End If End If End If Next Lrow DelRange.Delete End With ActiveWindow.View = ViewMode With Application .ScreenUpdating = True .Calculation = CalcMode End With End Sub 

也许使用这样的东西

  Sub DeleteZeroRows() Dim a() As Variant Dim l As Long a = Range("a1:a300000").Value For l = UBound(a) To 1 Step -1 If a(l, 1) = 0 Then Debug.Print "Row " & l & " delete" Rows(l).EntireRow.Delete End If Next l End Sub 

如果数据不包含任何公式,那么重构可能会削减10到15秒的执行时间。

在这里输入图像说明


 Sub DeleteRows() Const PageSize As Long = 20000 Dim rw As Range Dim Data Dim lStart As Long, lEnd As Long, lNextRow As Long Dim list As Object: Set list = CreateObject("System.Collections.ArrayList") ToggleEvents False MonitorTimes True With Worksheets("Sheet1").UsedRange For Each rw In .Rows If Not IsError(rw.Cells(1).Value) Then If rw.Cells(1).Value <> 0 Then list.Add rw.Formula End If Next MonitorTimes .Cells.ClearContents For lStart = 0 To list.Count Step PageSize lEnd = IIf(lStart + PageSize - 1 <= list.Count, PageSize, list.Count - lStart) Data = Application.Transpose(list.GetRange(lStart, lEnd).ToArray) Data = Application.Transpose(Data) With .Range("A1").Offset(lNextRow) .Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data lNextRow = lNextRow + PageSize End With Next End With MonitorTimes ToggleEvents True End Sub Static Sub ToggleEvents(EnableEvents As Boolean) Dim CalcMode As Long If EnableEvents Then With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With Else With Application .ScreenUpdating = True .Calculation = CalcMode End With End If End Sub Static Sub MonitorTimes(Optional ResetVariables As Boolean) Dim tLoad, Start Dim RowCount As Long, ColumnCount As Long If ResetVariables Then Start = 0 tLoad = 0 End If With Worksheets("Sheet1") If Start = 0 Then Start = Timer Debug.Print "Before: "; "Rows->"; WorksheetFunction.CountA(.Columns(1)); "Columns->"; WorksheetFunction.CountA(.Rows(1)) ElseIf tLoad = 0 Then tLoad = Timer - Start Else Debug.Print "After: "; "Rows->"; WorksheetFunction.CountA(.Columns(1)); "Columns->"; WorksheetFunction.CountA(.Rows(1)) Debug.Print "Load Time in Second(s): "; tLoad Debug.Print "Write Time in Second(s): "; Timer - Start - tLoad Debug.Print "Execution Time in Second(s): "; Timer - Start End If End With End Sub Sub RestoreTestData() Worksheets("Original").Cells.Copy Worksheets("Sheet1").Cells ThisWorkbook.Save End Sub