Help optimizing code to find items on a list

[termeric]

Hello, i have two lists that i need to compare, and if i find a match, i want to copy the entire row to athird sheet. i have one tab with ID numbers, which are only listed once. my other tab has the data and ID is present in many of the rows. Right now i added the ID's to a dictionary and then loop through the data to see if the dictionary entry exists, if so it does the copy. it took 50 seconds to loop through 1500 rows, how can i get this to run quicker?

Sub transfer()

Dim row As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim org As String
Dim i As Integer, k As Variant


row = Sheets("Swap").UsedRange.Rows.Count
k = 2
Sheets("Roster").Rows(1).Copy Sheets("_Roster").Range("A1")


For i = 2 To row
    org = Sheets("Swap").Range("D" & i).Value
    
    If dict.exists(org) Then
    Else
        dict.Add Key:=org, Item:=org
    End If

Next i

row = Sheets("Roster").UsedRange.Rows.Count

For i = 2 To row
    org = Sheets("Roster").Range("i" & i).Value
    
    If dict.exists(org) Then
        Sheets("Roster").Rows(i).Copy Sheets("_Roster").Range("A" & k)
        k = k + 1
    Else
        'dict.Add Key:=org, Item:=org
    End If
Next i

End Sub

 

[DanteAmor]

Since your macro is copying directly from the sheet and pasting to another sheet, that makes the process slow.
It might help if you put this instruction at the beginning of your macro:

Application.ScreenUpdating = False

But if you want to learn how to use arrays that will certainly make your macros faster.

With the following macro, I did a test with 10,000 records and the result is immediate.
Note: I assume that in row 1 you have the headers, I use that row to know how many columns you have in the "Roster" sheet.

Sub transfer_v1()
  Dim a As Variant, b As Variant, c As Variant
  Dim dic As Object
  Dim i As Long, j As Long, k As Long, lr As Long, lc As Long
  Dim sh_r As Worksheet
 
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh_r = Sheets("_Roster")
  sh_r.Cells.ClearContents
 
  With Sheets("Roster")
    lr = .Range("I" & Rows.Count).End(3).row
    lc = .Cells(1, Columns.Count).End(1).Column
    .Rows(1).Copy sh_r.Range("A1")
    a = .Range("A2", .Cells(lr, lc)).Value
    ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2))
  End With
 
  With Sheets("Swap")
    b = .Range("D2", .Range("D" & Rows.Count).End(3)).Value
    For i = 1 To UBound(b, 1)
      dic(b(i, 1)) = Empty
    Next i
  End With
 
  For i = 1 To UBound(a, 1)
    If dic.exists(a(i, 9)) Then       'column I
      k = k + 1
      For j = 1 To UBound(a, 2)
        c(k, j) = a(i, j)
      Next
    End If
  Next i

  sh_r.Range("A2").Resize(k, UBound(c, 2)).Value = c
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

 

[termeric]

@DanteAmor thanks for this, its exactly what i needed. do you have any reccommendations on where i can start reading up on arrays?

 

[termeric]

@DanteAmor one quick question, what would i need to change if i want to compare a different column from my Swap tab to a different sheet? i have 6 different lists that i am comparing, Swap C,D,E all have different ID's for the same group, so for example, I want to compare Reqs to Swap("C") and put the results on _Reqs

i tried this, but i'm gettign an error on the last line

Sub transfer_v3()
  Dim a As Variant, b As Variant, c As Variant
  Dim dic As Object
  Dim i As Long, j As Long, k As Long, lr As Long, lc As Long
  Dim sh_r As Worksheet
 
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh_r = Sheets("_Reqs")        'Changed to _Reqs
  sh_r.Cells.ClearContents
 
  With Sheets("Reqs")     'Changed to Reqs
    lr = .Range("M" & Rows.Count).End(3).row
    lc = .Cells(1, Columns.Count).End(1).Column
    .Rows(1).Copy sh_r.Range("A1")
    a = .Range("A2", .Cells(lr, lc)).Value
    ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2))
  End With
 
  With Sheets("Swap")
    b = .Range("C2", .Range("C" & Rows.Count).End(3)).Value  'Changed from D to C
    For i = 1 To UBound(b, 1)
      dic(b(i, 1)) = Empty
    Next i
  End With
 
  For i = 1 To UBound(a, 1)
    If dic.exists(a(i, 13)) Then       'Changed 9 to 13 , column M?
      k = k + 1
      For j = 1 To UBound(a, 2)
        c(k, j) = a(i, j)
      Next
    End If
  Next i

  sh_r.Range("A2").Resize(k, UBound(c, 2)).Value = c
End Sub

 

[DanteAmor]

Im glad to help you. Thanks for the feedback.

do you have any reccommendations on where i can start reading up on arrays?

In signature is the link to my youtube channel, there you will find about matrices and about dictionaries.

-------------

tried this, but i'm gettign an error on the last line

It is possible that there is no match, so try this:

Sub transfer_v1()
  Dim a As Variant, b As Variant, c As Variant
  Dim dic As Object
  Dim i As Long, j As Long, k As Long, lr As Long, lc As Long
  Dim sh_r As Worksheet
  
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh_r = Sheets("_Roster")
  sh_r.Cells.ClearContents
  
  With Sheets("Roster")
    lr = .Range("I" & Rows.Count).End(3).row
    lc = .Cells(1, Columns.Count).End(1).Column
    .Rows(1).Copy sh_r.Range("A1")
    a = .Range("A2", .Cells(lr, lc)).Value
    ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2))
  End With
  
  With Sheets("Swap")
    b = .Range("D2", .Range("D" & Rows.Count).End(3)).Value
    For i = 1 To UBound(b, 1)
      dic(b(i, 1)) = Empty
    Next i
  End With
  
  For i = 1 To UBound(a, 1)
    If dic.exists(a(i, 9)) Then       'column I
      k = k + 1
      For j = 1 To UBound(a, 2)
        c(k, j) = a(i, j)
      Next
    End If
  Next i

  If k = 0 Then
    MsgBox "No match"
  Else
    sh_r.Range("A2").Resize(k, UBound(c, 2)).Value = c
  End If
End Sub