How to make this lookup macro run faster? alternatives?

[hrithik]

The sheet "Main" has 104334 entries (lr) and sheet "Sheet1" has 26500 entries (LRb). The macro is an overkill, takes an eternity.
Is there any way to make it faster or possible alternatives...experts please help!

Sub mymac()
Dim j, i, lr, LRb As Long
Dim temp As Integer
Sheets("Main").Select
lr = ActiveSheet.UsedRange.Rows.Count
LRb = Range("'Sheet1'!" & "A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = 2 To lr
temp = WorksheetFunction.CountIf(Range("'Sheet1'!" & "A2:A" & LRb), Range("A" & i).Value)
If temp = 0 Then
Range("D" & i).Value = 0
Else
Range("D" & i).Value = 1
End If
Next
Application.ScreenUpdating = True
End Sub

Note: the functionality is to lookup Main sheet col A entries in Sheet1, and indicate a match by 1 or a no match by 0.

 

[MrKowz]

Give this a shot:

Sub mymac()
Dim i   As Long, _
    LR  As Long, _
    LRb As Long, _
    x   As Variant
    
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With
With Sheets("Main")
    LR = .ActiveSheet.UsedRange.rows.Count
    LRb = Sheets("Sheet1").Range("A" & rows.Count).End(xlUp).row
    For i = 2 To LR
        Application.StatusBar = "Currently checking row " & i
        x = Application.Match(Range("A" & i).Value, Sheets("Sheet1").Range("A2:A" & LRb), 0)
        If IsError(x) Then
            Range("D" & i).Value = 0
        Else
            Range("D" & i).Value = 1
        End If
    Next
End With
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .StatusBar = False
End With
End Sub

 

[hrithik]

@MrKowz, your code works better [takes about 12 mins].....is it possible to get even faster?

 

[MrKowz]

With that amount of data, I don't think there will be a way to make it noticably faster.

 

[RoryA]

Have you tried just entering the formulas in the cells in D and then replacing them with their values afterwards?

 

[ZVI]

Try the less than 1 sec solution:

Sub ExistanceOfMainInSheet1()
  Dim Rng As Range, t As Single, r As Long, a
  t = Timer
  
  ' Copy column A data of sheet "Sheet1" into array a()
  With Sheets("Sheet1")
    If .FilterMode Then .ShowAllData
    a = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Value
  End With
  
  ' Main processing
  With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    ' Create dictionary using data of Sheet1 Column A
    For r = 1 To UBound(a)
      .Item(a(r, 1)) = 0
    Next
    ' Copy column A data of sheet "Main" into array a()
    With Sheets("Main")
      Set Rng = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
      a = Rng.Value
    End With
    ' Loop throuch a() and check existence of its values in the dictionary
    ' Put results of cheking into the same array a()
    For r = 1 To UBound(a)
      If .Exists(a(r, 1)) Then
        a(r, 1) = 1
      Else
        a(r, 1) = 0
      End If
    Next
  End With

  ' Copy a() to column D of sheet "Main"
  With Application
    .EnableEvents = False
    .ScreenUpdating = False
    ' Do offseting for column D and copy
    With Rng.Offset(, 3)
      .Value = a
    End With
    .EnableEvents = True
    .ScreenUpdating = True
  End With

  Debug.Print Round(Timer - t, 3)
End Sub

 

[MrKowz]

Try the less than 1 sec solution:

Sub ExistanceOfMainInSheet1()
 Dim Rng As Range, t As Single, r As Long, a
 t = Timer
 
 ' Copy column A data of sheet "Sheet1" into array a()
 With Sheets("Sheet1")
   If .FilterMode Then .ShowAllData
   a = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Value
 End With
 
 ' Main processing
 With CreateObject("Scripting.Dictionary")
   .CompareMode = 1
   ' Create dictionary using data of Sheet1 Column A
   For r = 1 To UBound(a)
     .Item(a(r, 1)) = 0
   Next
   ' Copy column A data of sheet "Main" into array a()
   With Sheets("Main")
     Set Rng = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
     a = Rng.Value
   End With
   ' Loop throuch a() and check existense of its values in the dictionary
   ' Put results of cheking into the same array a()
   For r = 1 To UBound(a)
     If .Exists(a(r, 1)) Then
       a(r, 1) = 1
     Else
       a(r, 1) = 0
     End If
   Next
 End With
 ' Copy a() to column D of sheet "Main"
 With Application
   .EnableEvents = False
   .ScreenUpdating = False
   ' Do offseting for column D and copy
   With Rng.Offset(, 3)
     .Value = a
   End With
   .EnableEvents = True
   .ScreenUpdating = True
 End With
 Debug.Print Round(Timer - t, 3)
End Sub

Wow, I really need to learn how to use the Scripting.Dictionary object. Do you happen to have any links that go over its usage?

 

[ZVI]

Wow, I really need to learn how to use the Scripting.Dictionary object. Do you happen to have any links that go over its usage?

Below are two links for overview:
MSDN: Dictionary Object
CPearson: Collection And Dictionary Procedures
There are a lot of VBA implementations with the Dictionary usage in this Board, please use word Dictionary as the key for the seaching