Question

I am trying to return a row of data if the value in column A which is a unique key for that row does not appear in a different sheet and column. The keys look like this 5028-10/15/2021-10000000021-80 (the key is created based on the data in the row) Each of the two data sets will have these keys in each row and either data set could have 10,000 to 300,000+ rows. Generally speaking the two data sets should contain the exact same data, but it needs to be confirmed and the key allows for comparison. Normally, Vlookup is used and works just fine. However I am trying to automate this process in VBA. When I run the following code, it runs, but it runs for minutes (on test data with 30,000 rows) and doesn t return the correct result. Further, why is vlookup almost instant when returning the answer (I put it in the 30,000 rows and it has no problem).

下面是一些不匹配的 du子数据。因此,该法典应当退回。 (或至少在以下法典中告诉我钥匙)。

Sub Summarize()
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim WS3 As Worksheet

Dim C As Range

Set WS1 = Workbooks("Book1.xlsm").Sheets(1)
Set WS2 = Workbooks("Book2.xlsx").Sheets(1)
Set WS3 = Workbooks("Book3.xlsx").Sheets(1)

For Each Cell In WS2.Range("A2:A30100")
    With WS3.Range("A1:A30100")
        Set C = .Find(Cell.Value, LookIn:=xlValues)
        If Not C Is Nothing Then
            
        Else
            Debug.Print (cell.Value)
        End If
    End With
Next

End Sub

when running the code, it indicated that many of the keys could not be found when searching the data set but as noted above there is only one that does not trace. I don t know why it s saying some of the keys can t be found, and why it is taking so long to search through the list. As note, i did get .find() to work while at the office (this is a reproduction of the code) but it was still very slow and I feel that there has to be a faster way.

Answer 1

在囚室进行手术(包括搜查)需要时间。在你的法典中多次进行搜查(30099 * 30099)是费时的。
It would be more efficient to validate data using an array in memory.
根据我的测试,只有0.13英亩的40K行被鉴定。

Option Explicit
Sub Demo()
    Dim objDic As Object
    Dim i As Long, sKey As String
    Dim arrData3, arrData2, lastRow As Long
    Dim WS2 As Worksheet, WS3 As Worksheet
      Set WS2 = Workbooks("Book2.xlsx").Sheets(1)
      Set WS3 = Workbooks("Book3.xlsx").Sheets(1)
    Set WS2 = ActiveWorkbook.Sheets(1)   for testing
    Set WS3 = ActiveWorkbook.Sheets(2)
    Set objDic = CreateObject("scripting.dictionary")
    lastRow = WS3.Cells(WS3.Rows.Count, 1).End(xlUp).Row
    arrData3 = WS3.Range("A2:A" & lastRow).Value
    For i = LBound(arrData3) To UBound(arrData3)
        sKey = arrData3(i, 1)
        If Not objDic.exists(sKey) Then
            objDic(sKey) = i + 1
        End If
    Next i
    arrData2 = WS2.Range("A2:A" & lastRow).Value
    For i = LBound(arrData2) To UBound(arrData2)
        sKey = arrData2(i, 1)
        If Not objDic.exists(sKey) Then
            Debug.Print "Row : " & i + 1 & ", Value: " & sKey
        End If
    Next i
End Sub

Answer 2

Find Missing IDs Using `Application.Match`

The source sheet is the one whose IDs need to be found in the lookup sheet.
This will write the missing IDs to column A of a 3rd (destination) sheet.
Not tested!

Sub FindMissing()
    
    Dim lws As Worksheet: Set lws = Workbooks("Book3.xlsx").Sheets(1)
    Dim lrg As Range: Set lrg = lws.Range("A1:A30100")
    
    Dim sws As Worksheet: Set sws = Workbooks("Book2.xlsx").Sheets(1)
    Dim srg As Range: Set srg = sws.Range("A2:A30100")
    Dim srCount As Long: srCount = srg.Rows.Count
    
    Dim lrIndices As Variant: lrIndices = Application.Match(srg, lrg, 0)
    
    Dim lrCount As Long: lrCount = Application.Count(lrIndices)
    
    If lrCount = srCount Then
        MsgBox "No missing IDs.", vbInformation
        Exit Sub
    End If
    
    Dim drCount As Long: drCount = srCount - lrCount
    Dim dData() As Variant: ReDim dData(1 To drCount, 1 To 1)
    
    Dim sData() As Variant: sData = srg.Value
    
    Dim sr As Long, dr As Long
    
    For sr = 1 To srCount
        If IsError(lrIndices(sr, 1)) Then
            dr = dr + 1
            dData(dr, 1) = sData(sr, 1)
        End If
    Next sr
    
    Dim dws As Worksheet: Set dws = Workbooks("Book1.xlsm").Sheets(1)
    Dim dcell As Range:
    Set dcell = dws.Cells(dws.Rows.Count, "A").End(xlUp).Offset(1)
    
    dcell.Resize(drCount).Value = dData

    MsgBox "Found " & dr & " missing IDs.", vbInformation

End Sub

Find Missing IDs Using Application.Match

友情链接

Find Missing IDs Using `Application.Match`