我的问题:我正在尝试删除列AH
中表格中的行,而标准是" Del"所以列AH
中的任何单元格,我想删除该表中的整行。
我尝试了很多不同的代码,大多数代码都是永久性的,因为我要删除10000多行。我从网站上找到了此代码,但我从subscript out of range Error9
行收到错误If Intersect
:
Private Sub deleteTableRowsBasedOnCriteria(tbl As ListObject, _
columnName As String, _
criteria As String)
Dim x As Long, lastrow As Long, lr As ListRow
lastrow = tbl.ListRows.Count
For x = lastrow To 1 Step -1
Set lr = tbl.ListRows(x)
If Intersect(lr.Range, tbl.ListColumns(columnName).Range).Value = criteria Then
'lr.Range.Select
lr.Delete
End If
Next x
End Sub
然后我打电话给sub如下:
Set tbl = ThisWorkbook.Worksheets("Sheet1").ListObjects("Table4")
Call deleteTableRowsBasedOnCriteria(tbl, "AH", "Del")
任何帮助都会很棒。谢谢。
答案 0 :(得分:1)
您应该只能使用AutoFilter
而不是循环。它要快得多。
Sub Macro1()
Dim wks As Worksheet
Dim tbl As ListObject
Dim lastRow As Long
Dim rng As Range
Set wks = ActiveWorkbook.Sheets("Sheet1")
Set tbl = wks.ListObjects("Table4")
' Filter and delete all rows that have "Del" in it
With tbl.Range
' Switch off the filters before turning it on
.AutoFilter
' Field:=34 must be equal to the column where you have the criteria in
.AutoFilter Field:=34, Criteria1:="Del"
' Set the range for the filtered cells
Set rng = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
.AutoFilter ' Turn off the filter
rng.Delete ' Delete the filtered cells
End With
End Sub
答案 1 :(得分:0)
我稍微改变了你的代码并添加了一个按钮来执行删除行功能。我使用按钮标题显示已删除的行数,以便您知道发生了什么。关键是调用DoEvents
以便刷新所有内容并在删除行时更改按钮标题:
添加按钮CommandButton1
并尝试以下代码:
Private Sub CommandButton1_Click()
Dim rowsDeleted As Long
Call deleteTableRowsBasedOnCriteria("H", "Del")
End Sub
Private Sub deleteTableRowsBasedOnCriteria(columnName As String, criteria As String)
Dim x As Long, lastrow As Long, lr As ListRow, rowsDeleted As Long, deletedShift As Long
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
rowsDeleted = 0
deletedShift = 0
For x = lastrow To 1 Step -1
If Cells(x, Range(columnName & 1).Column) = "Del" Then
Rows(x).Delete
rowsDeleted = rowsDeleted + 1
deletedShift = deletedShift + 1
If deletedShift >= 30 Then
CommandButton1.Caption = "Deleted " & rowsDeleted & " rows"
deletedShift = 0
DoEvents
End If
End If
Next x
MsgBox "Total rows deleted: " & rowsDeleted
End Sub
答案 2 :(得分:0)
在像这样的大型数据集上,我更喜欢使用数组而不是删除行。将Target
单元格值加载到数组(Data)中然后创建第二个相同大小的空数组(NewData),这个概念非常简单。接下来,遍历数据并复制要在NewData中保留下一个空行的任何数据行。最后,使用NewData覆盖Target
单元格值,有效地删除您不想保留的行。
我实际上通过添加PreserveFormulas
参数更进了一步。如果PreserveFormulas = True
则将公式复制到NewData,而不仅仅是值。
注意:每隔一行删除59507行。我比较了Array Delete Data Only,Array Delete Preserve Formulas,Union Method和Filter Method。 Download Test Stub
Sub Test()
Dim tbl As ListObject
Set tbl = ThisWorkbook.Worksheets("Sheet1").ListObjects("Table1")
Call deleteTableRowsBasedOnCriteria(tbl, "AH", "Del", False)
Debug.Print
Set tbl = ThisWorkbook.Worksheets("Sheet2").ListObjects("Table13")
Call deleteTableRowsBasedOnCriteria(tbl, "AH", "Del", True)
End Sub
Sub deleteTableRowsBasedOnCriteria(tbl As ListObject, columnName As String, criteria As String, PreserveFormulas As Boolean)
Dim Start: Start = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim Data, Formulas, NewData
Dim col As Long, pos As Long, x As Long, y As Long
col = Columns(columnName).Column
Data = tbl.DataBodyRange.Value
If PreserveFormulas Then Formulas = tbl.DataBodyRange.Formula
ReDim NewData(1 To UBound(Data, 1), 1 To UBound(Data, 2))
For x = 1 To UBound(Data, 1)
If Data(x, col) <> criteria Then
pos = pos + 1
For y = 1 To UBound(Data, 2)
If PreserveFormulas Then
NewData(pos, y) = Formulas(x, y)
Else
NewData(pos, y) = Data(x, y)
End If
Next
End If
Next
tbl.DataBodyRange.Formula = NewData
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print "Preserve Formulas: "; PreserveFormulas
Debug.Print "Original RowCount: "; UBound(Data, 1); " Column Count: "; UBound(Data, 2)
Debug.Print "New RowCount: "; pos
Debug.Print UBound(Data, 1) - pos; " Rows Deleted"
Debug.Print "Execution Time: "; Timer - Start; " Second(s)"
End Sub