vba - 基于列表删除VBA中的行
问题描述
我的电子表格中有两个选项卡(报告和假期)。在假期选项卡的 A 列中有一个日期列表(手动更新),我想从报告选项卡中排除(E 列包含日期)。
我找到了一个代码,它可以满足需要,但当行数约为 100-200k 时需要一些时间:
Sub Holidays()
Application.DisplayAlerts = False
Dim d As Object, e, rws&, cls&, i&, j&
Set d = CreateObject("scripting.dictionary")
For Each e In Sheets("Holidays").Range("A1").CurrentRegion
d(e.Value) = 1
Next e
Sheets("Report").Activate
rws = Cells.Find("*", After:=[a1], SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
cls = Cells.Find("*", After:=[a1], SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
For i = rws To 1 Step -1
For j = 1 To cls
If d(Range("A1").Resize(rws, cls)(i, j).Value) = 1 Then _
Cells.Rows(i).Delete: Exit For
Next j, i
Application.DisplayAlerts = True
End Sub
有没有办法加速那个宏?理想情况下,它应该只需要几秒钟即可运行。
预先感谢您的帮助。
解决方案
这应该会在不到 30 秒的时间内从 200 K 中删除大约 10 K 行
下面的代码假定UsedRange
在两张纸上都以A1
, 和
- 工作表
Holidays
仅包含列A
(在连续的行中) - 工作表
Report
包含要在列中删除的日期E
(在连续的行中) - 两张纸上的日期格式为
"m/d/yyyy"
Option Explicit
Public Sub RemoveHolidaysFromReportFilterUnion()
Const WS_NAME = "Report"
Dim wsH As Worksheet: Set wsH = ThisWorkbook.Worksheets("Holidays")
Dim wsR As Worksheet: Set wsR = ThisWorkbook.Worksheets(WS_NAME)
Dim del As Range, wsNew As Worksheet
Application.ScreenUpdating = False
Set del = GetRowsToDelete(wsH, wsR)
If del.Cells.Count > 1 Then
del.EntireRow.Hidden = True
Set wsNew = ThisWorkbook.Worksheets.Add(After:=wsR)
wsR.UsedRange.SpecialCells(xlCellTypeVisible).EntireRow.Copy
With wsNew.Cells(1)
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteAll
.Select
End With
Application.DisplayAlerts = False
wsR.Delete
Application.DisplayAlerts = True
wsNew.Name = WS_NAME
End If
Application.ScreenUpdating = True
End Sub
Private Function GetRowsToDelete(ByRef wsH As Worksheet, ByRef wsR As Worksheet) As Range
Const HOLIDAYS_COL = "A"
Const REPORT_COL = "E"
Dim arr As Variant, i As Long, itm As Variant
ReDim arr(1 To wsH.UsedRange.Rows.Count - 1)
i = 1
For Each itm In wsH.UsedRange.Columns(HOLIDAYS_COL).Offset(1).Cells
If Len(itm) > 0 Then
arr(i) = itm.Text 'Create AutoFilter Array (dates as strings)
i = i + 1
End If
Next
Dim ur As Range, del As Range, lr As Long, fc As Range
With wsR.UsedRange
Set ur = .Resize(.Rows.Count - 1, 1).Offset(1)
Set del = wsR.Cells(.Rows.Count + 1, REPORT_COL)
End With
lr = wsR.UsedRange.Rows.Count
Set fc = wsR.Range(wsR.Cells(1, REPORT_COL), wsR.Cells(lr, REPORT_COL))
fc.AutoFilter Field:=1, Criteria1:=arr, Operator:=xlFilterValues
If fc.SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
Set del = Union(del, ur.SpecialCells(xlCellTypeVisible))
End If
fc.AutoFilter
Set GetRowsToDelete = del
End Function
表现 -Removed about 5K rows out of a total of 100K
Sheet Report - Rows: 100,011, Cols: 11 (Rows Left: 94,805 - Deleted: 5,206)
Sheet Holidays - Rows: 20, Cols: 1
Initial Sub - Holidays() - Time: 112.625 sec
RemoveHolidaysFromReportFilterUnion() - Time: 10.512 sec
测试数据
Holidays
Report
-Before
Report
-After
推荐阅读
- r - 在R中为经纬度数据创建半径内的质心标签
- html - html div 折叠问题
- javascript - 使用 'this' == undefined TypeError 调用动态选择的类方法结果
- javascript - 当我在可编辑的 div 中按 enter 时,如何阻止 HTML 文档生成另一个 li 元素?
- javascript - 使用 AJAX 和数据表刷新数据表
- javascript - Hooks 和 Api 调用
- sql - 查找所有账户中余额最高的账户的客户名称、客户街道、客户城市
- bootstrap-4 - Oracle APEX - 引导材料仪表板
- python - Pandas DataFrame:在两列上对多个组进行分组和计数
- azure - 为什么选择 Azure FHIR 服务器?是否存在“技术”差异?