問題描述
Metode yang efisien untuk menghapus baris dalam spreadsheet (Efficient method of deleting rows in a spreadsheet)
Is there better method of deleting rows in an excel spreadsheet than than what I currently use?
On a spreadsheet I run a macro that deletes a row if a figure in a particular cell is '0'.
Public Sub deleteRowsIfZero(colDelete As Integer)
Dim r As Long
Application.ScreenUpdating = False
For r = Cells(Rows.Count, colDelete).End(xlUp).Row To 1 Step ‑1
If Cells(r, colDelete).Value = "0" Then Rows(r).Delete
Next r
Application.ScreenUpdating = True
End Sub
This works, but with a spreadsheet of 700+ rows it can be quite slow. Is there a more efficient method to do this?
Thanks in advance for any advice.
Cheers
Noel
‑‑‑‑‑
參考解法
方法 1:
I'd use a contiguous range and delete it in one go:
Public Sub deleteRowsIfZero(strSeekValue As String)
Dim lngRowsToDelete() As Long
Dim strRowsToDelete() As String
Dim x As Long, y As Long, n As Long, z As Long
On Error GoTo err_
'get the extent of the workbook range
x = Me.UsedRange.Rows.Count
n = ‑1
'switch off screen updating and calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'starting from row 1, look for the strSeekValue in column A, keep going till x is reached
For y = 1 To x
If Me.Range("A" & y).Value = strSeekValue Then 'if we find one, pop the row number into the array
n = n + 1
ReDim Preserve lngRowsToDelete(0 To n)
lngRowsToDelete(n) = y
End If
Next y
'if none were found, don't do the next bit
If n = ‑1 Then GoTo err_
'create a string of all the rows we found
z = 0
ReDim strRowsToDelete(z)
For y = 0 To n
strRowsToDelete(z) = strRowsToDelete(z) & lngRowsToDelete(y) & ":" & lngRowsToDelete(y) & ","
If Len(strRowsToDelete(z)) > 240 Then 'As A.Webb points out, the 255 limit will be a problem here
strRowsToDelete(z) = Left(strRowsToDelete(z), Len(strRowsToDelete(z)) ‑ 1) 'drop the trailing comma
z = UBound(strRowsToDelete) + 1 'resize the array
ReDim Preserve strRowsToDelete(0 To z)
End If
Next y
For y = z To 0 Step ‑1
If Right(strRowsToDelete(z), 1) = "," Then strRowsToDelete(z) = Left(strRowsToDelete(z), Len(strRowsToDelete(z)) ‑ 1)
'now delete the rows
Me.Range(strRowsToDelete(y)).EntireRow.Delete
Next y
err_:
'assumes calculation was set to auto
Application.Calculation = xlCalculationAutomatic
If Err Then Debug.Print Err.Description
Application.ScreenUpdating = True
End Sub
'run sub foo
Sub foo()
deleteRowsIfZero "0"
End Sub
方法 2:
Turn off screen updating and calculation before you begin and restore those settings at the end.
Note that you are unnecessarily retesting a row every time you delete because the deletion slides the rows up. Therefore you could decrement r
each time you do a deletion for a small optimization.
A further optimization would be to read in all the test values at one time. Each read/write from/to Excel/VBA has an overhead. See example below:
Dim r As Long, n As Long
Dim testcells As Variant
n = Cells(Rows.count, rowdelete).End(xlUp).Row
testcells = Range(Cells(n, rowdelete), Cells(1, rowdelete)).Value
For r = n To 1 Step ‑1
If testcells(r, 1) = 0 Then
Rows(r).Delete
End If
Next r
You can also try deleting all at once to see which is faster.
Dim r As Long, n As Long
Dim testcells As Variant
Dim del As Range
n = Cells(Rows.Count, rowdelete).End(xlUp).Row
testcells = Range(Cells(n, rowdelete), Cells(1, rowdelete)).Value
For r = n To 1 Step ‑1
If testcells(r, 1) = 0 Then
If del Is Nothing Then Set del = Rows(r)
Set del = Union(del, Rows(r))
End If
Next r
If Not (del Is Nothing) Then
del.Delete
End If
方法 3:
If there are few errors expected, it should be quicker to find matching cells and delete them. Column D is serving for holding characters for deleting.
Sub DeleteRowWithCertainValue()
Dim del_char As String
del_char = "0"
Do
On Error GoTo ErrorHandler
Sheets("Sheet1").Range("D:D").Find(What:=del_char, _
After:=Range("D1"), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False).EntireRow.Delete
Loop
ErrorHandler: Exit Sub
End Sub
(by noelmcg、Zilpher、A. Webb、Jüri Ruut)