This allows me to search each cell J4:J6525 in range K4:K6525. If it is found it will paste the values in Offset(0, 2) (column M).

I run it for files with more than 60000 lines, and sometimes much bigger. It takes a long time to complete. How can I make this run faster?

Sub Finder()

Dim WhereToSearch As Range, WhatToSearch As Range, ValueFound As Range, ValueSearched As Range

Set WhereToSearch = ActiveSheet.Range("K4:K6525")
Set WhatToSearch = ActiveSheet.Range("J4:J6525")

For Each ValueSearched In WhatToSearch

Set ValueFound = WhereToSearch.Find(What:=ValueSearched, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

If Not ValueFound Is Nothing Then

ValueFound.Offset(0, 2) = ValueFound

End If
End Sub

Arrays and a dictionary

Everyone draws their own 'line in the sand' but for me, anything involving more than 5000-7000 values belongs in an array and looking for duplicates should involve a Scripting.Dictionary which has its own unique index of Keys.

Option Explicit

Sub dupeFinder()

    Dim d As Long
    Dim aJAYs As Variant, aKAYs As Variant, aEMs As Variant

    'late binding
    Dim dJAYs As Object
    Set dJAYs = CreateObject("Scripting.Dictionary")
    'early binding: see footnote ¹
    'dim dJAYs as new scripting.dictionary

    With ActiveSheet    '<~~ better as With Worksheets("Sheet1x") you really should know what worksheet you are on

        'bulk load aJAYs and aKAYs; redim aEMs
        aJAYs = .Range(.Cells(4, "J"), .Cells(.Rows.Count, "J").End(xlUp)).Value2
        aKAYs = .Range(.Cells(4, "K"), .Cells(.Rows.Count, "K").End(xlUp)).Value2
        ReDim aEMs(LBound(aKAYs) To UBound(aKAYs), 1 To 1)

        'load dictionary dJAYs from array aJAYs
        For d = LBound(aJAYs, 1) To UBound(aJAYs, 1)
            dJAYs.Item(aJAYs(d, 1)) = aJAYs(d, 1)
        Next d

        'loop through aKAYs looking for matches using dictionary index
        For d = LBound(aKAYs, 1) To UBound(aKAYs, 1)
            If dJAYs.exists(aKAYs(d, 1)) Then aEMs(d, 1) = aKAYs(d, 1)
        Next d

        'bulk dump the aEMs back onto the worksheet
        .Cells(4, "M").Resize(UBound(aEMs, 1), UBound(aEMs, 2)) = aEMs

    End With

End Sub

Results: 80K values in column J, 60K values in column K, ~50% match in 1.23 seconds.


¹ If you can convert the late binding of the Scripting.Dictionary to early binding, you must add Microsoft Scripting Runtime to the VBE's Tools ► References.

  • \$\begingroup\$ This is 15x or 20x faster than the code I had. It's excellent. I would like to understand more the code so that I will understand more what each line does. Can I ask you to put more comments? \$\endgroup\$ – Pikk Jul 2 '16 at 22:32
  • \$\begingroup\$ I'll try to respond to direct questions but I generally do not want to regurgitate anything that is adequately covered in official MSDN documentation. I may also answer by editing the answer above but I will leave a @Pikk notice in comments so you notice them (and delete the notices later). \$\endgroup\$ – user66882 Jul 2 '16 at 22:37
  • \$\begingroup\$ That would be great. ` appTGGL bTGGL:=True` should turn on the other procedure, but nothing changes when I turn it into true, I suspect it should calculate the duration of the main procedure. Is that normal? I'd be glad if you can add more comments in the part from ReDim to End With, that's the part I don't understand so much. \$\endgroup\$ – Pikk Jul 3 '16 at 9:25
  • \$\begingroup\$ I've removed the confusion. Given the method(s) used, I do not see it making more than a 5-10% difference in any event, \$\endgroup\$ – user66882 Jul 3 '16 at 12:14

It's hard to beat the performance of standard Excel WorksheetFunctions.
This will find the matches.

Range("M4:M6525").Formula = "=IF(ISNA(MATCH(J4,$K$4:$K$6525,0)),"""",INDEX($K$4:$K$6525,MATCH(J4,$K$4:$K$6525,0), 1))"

Then if you want to remove the formulae use this

Range("M4:M6525").Value =Range("M4:M6525").Value


Do you have a little more information about the data? Are the values unique (you only search for the first match)? Do you expect many matches?

It usually gives a performance boost to load the values into an array instead of looping over the sheet (and accessing it every iteration) as in

Dim i As Long
Dim whereToSearchArr As Variant
Dim v As Variant
whereToSearchArr = whereToSearch.Value

'set the options before the loop (not sure if that makes much of a difference)
WhereToSearch.Find(What:="*", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

For Each v In whereToSearchArr
    Set ValueFound = WhereToSearch.Find(v)
    If Not ValueFound Is Nothing Then ValueFound.Offset(0, 2).Value = v
Next v

The Range.Find method should be reasonable fast to find one occurrence. I'm not sure about the overhead of starting the Find method and setting a range though so you could try to replace it by another loop that goes through another array (whereToSearchArray) using an index and then writes to the corresponding line. This would also be my method of choice if you wanted to find all occurrences instead of just the first. See this answer I wrote about different methods to search and replace within a large range.

  • \$\begingroup\$ The data usually are Serial Numbers, so numbers and/or letter and sometimes other symbols like -. The values in the source list (what has to be found) may be not unique, so it has to do it for each item. In the target (where to search) also can be not unique - but I need to see if the SN in X is present also in Y. \$\endgroup\$ – Pikk Jul 2 '16 at 16:26

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.