найдите значение ячейки в диапазоне и, если не найдено, удалите строку. на бег требуется 120+ минут

Question

У меня есть следующий код, но из-за того, что лист, который я обрабатываю, имеет 190 000 строк данных, для его обработки требуется более 120 минут:

Начать с

Sub Import_Data()

    Start_Import "WIR-Deploy"

End Sub

Затем здесь я все устанавливаю:

Option Explicit
Public WB1 As Workbook
Public WS1 As Worksheet
Public WS2 As Worksheet
Public updateSuccess As Boolean
Sub Start_Import(strApp As String)
    Dim WS3 As Worksheet
    Dim importFile As String

    Set WB1 = ThisWorkbook

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set WS1 = WB1.Sheets("Master Sheet")

    If strApp = "WIR-Deploy" Then
        Set WS2 = WB1.Sheets("RawWhoIsReady-Deploy@8Jul")
        importFile = "H:\99 - Temp\WhoIsReady-Deploy.csv"
        Application.StatusBar = "'Who is ready - Deploy' data Import now runnning..."

    Else
        MsgBox "Not Coded Yet"
        Exit Sub
    End If

    If strApp = "WIR-Deploy" Then
        ImportData strApp, importFile
    Else
        MsgBox "Not Coded Yet"
        Exit Sub
    End If

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.StatusBar = False

End Sub

, а затем импортирует лист:

Option Explicit
Sub ImportData(strApp, importFile)
    Dim WB2 As Workbook
    Dim WS3 As Worksheet
    Dim lRow, lCol, ImportRow As Long
    Dim rngAsset As Range

    Set WB2 = Workbooks.Open(importFile)

    If strApp = "WIR-Deploy" Then
        WB2.Sheets(1).Copy Before:=WS2
        WB2.Close False
        Set WS3 = WB1.ActiveSheet

        WS3.Columns(1).EntireColumn.Delete
        lRow = Cells(Rows.Count, 1).End(xlUp).Row
        lCol = Cells(1, Columns.Count).End(xlToLeft).Column
    
        With WS3
            .Sort.SortFields.Add Key:=Range("A1"), Order:=xlAscending
            .Sort.SetRange Range(.Cells(1, 1), .Cells(lRow, lCol))
            .Sort.Header = xlYes
            .Sort.Apply
        End With

        For ImportRow = 2 To lRow
            Set rngAsset = WS1.Range("A:A").Find(WS3.Cells(ImportRow, 1))
            If rngAsset Is Nothing Then
                WS3.Rows(ImportRow).EntireRow.Delete
                ImportRow = ImportRow - 1
                lRow = lRow - 1
            End If
    
            Application.StatusBar = "[Deploy Import] " & lRow & " left to process. " & ImportRow & " Retained"
    
            Set rngAsset = Nothing

        Next
    Else
        MsgBox "This has not been coded yet", vbOKOnly + vbCritical
        Exit Sub
    End If

    'WS3.Delete
    WB1.RefreshAll

End Sub

Можно ли как-нибудь ускорить этот процесс? Как это сделать лучше? Мои ограниченные знания говорят о том, что я бы изо всех сил пытался сделать это быстрее, но я открыт для любых идей, как сделать его лучше

Answer 1

Примерно так:

Dim m, rngDel As Range, numDel As Long
'...

numDel = 0
For importrow = lRow To 2 Step -1
    'Match is much faster than Find...
    m = Application.Match(ws3.Cells(importrow, 1).Value, WS1.Range("A:A"), 0)
    
    If IsError(m) Then
        
        numDel = numDel + 1  '<< count rows added
        If rngDel Is Nothing Then
            Set rngDel = ws3.Rows(importrow)
        Else
            Set rngDel = Application.Union(rngDel, ws3.Rows(importrow))
        End If
        
        'delete in batches
        If numDel > 1000 Then
            rngDel.Delete
            Set rngDel = Nothing
            numDel = 0
        End If

    End If
   
    'don't update statusbar too often
    If importrow Mod 1000 = 0 Then
        Application.StatusBar = "On row " & importrow
    End If
Next

'delete last batch of rows
If Not rngDel Is Nothing Then rngDel.Delete

Вы можете поэкспериментировать с удалением rngDel, когда он достигнет определенного размера: я помню, что добавление новых строк может стать медленнее, когда размер станет слишком большим ...