Question

我的电子表格中有两个标签（报告和假期）。在假期选项卡的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

有没有办法加快这个宏？理想情况下，运行只需几秒钟。

提前感谢您的帮助。

Answer 1

这应该在不到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

Answer 2

我建议使用数组。

为日期列表填充一个数组。例如：

arr = Array（“ Alpha”，“ Bravo”，“ Charlie”）
根据条件过滤报告。

Sheet17.Range("E1").AutoFilter Field:=5, Criteria1:=arr, Operator:=xlFilterValues

过滤工作表后，创建一系列选定的可见单元格

set myrange = range("A1:F" &_

Cells(Rows.Count,"A").end(xlup).row).SpecialCells(xlCellTypeVisible)

使用Range(“YourRange”).EntireRow.Delete

这将删除4次操作中的范围，而不是根据条件循环遍历范围中的每一行。

希望有帮助！

根据列表

2 个答案:

我建议使用数组。