VBA Find Loop takes too long

L

Lil Stinker

Board Regular
Joined
Feb 16, 2022
Messages
151
Office Version
  1. 2019
Platform
  1. Windows
I'm using the code below (courtesy of @DanteAmor) to find and match serial numbers listed on two different sheets. Sheet 1 is where the serial numbers are entered by the user. Sheet 2 is the inventory of existing serial numbers. The code finds the numbers that are input on Sheet 1, matches them on Sheet 2 and updates the status as IN or OUT, adds a location and the date. The problem is it works fine on a small data set for testing however, the actual inventory list contains around 3000 entries. Just trying to match 13 serial numbers from Sheet 1 on Sheet 2 takes Excel almost a full minute to process. There could potentially be a few hundred serial numbers entered on Sheet 1 which I imagine could end up crashing Excel. Not to mention the inventory increasing beyond 3000 entries.

Is there a way to improve the existing code to run faster? I've already tried disabling ScreenUpdating, Calculation and EnableEvents with no improvement. I've also tried shortening the Range from "B:B" to "B2:B9999", still no faster. Looking for any ideas.

VBA Code: 
Sub out_serial_number_v2()
  Dim rng As Range, c As Range, f As Range
  Dim dt As Date, lo As String, cad As String
  
  With Sheets("Sheet1")
    Set rng = .Range("B11:O90")
    dt = .Range("A1").Value
    lo = .Range("H1").Value
  End With
  
  For Each c In rng
    If c.Value <> "" Then
      With Sheets("Sheet2")
        Set f = .Range("B:B").Find(c.Value, , xlValues, xlWhole, , , False)
        If Not f Is Nothing Then
          .Range("E" & f.Row).Value = "OUT"
          .Range("F" & f.Row).Value = lo
          .Range("G" & f.Row).Value = dt
        Else
          cad = cad & c.Value & vbCr
        End If
      End With
    End If
  Next
  If cad <> "" Then
    MsgBox cad, , "Serial number was not found in inventory"
  End If
End Sub
 

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
Sort by date Sort by votes
Try the following and comment how long it takes with all the records.


VBA Code: 
Sub out_serial_number()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim a As Variant, b As Variant, c As Variant
  Dim dic As Object
  Dim i&, j&, wRow&
  Dim dt As Date, lo As String, cad As String
 
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  Set dic = CreateObject("Scripting.Dictionary")
 
  a = sh1.Range("B11:O" & sh1.Range("B:O").Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row).Value
  b = sh2.Range("B2:B" & sh2.Range("B" & Rows.Count).End(3).Row).Value
  c = sh2.Range("E2:G" & sh2.Range("B" & Rows.Count).End(3).Row).Value
 
  dt = sh1.Range("A1").Value
  lo = sh1.Range("H1").Value
 
  For i = 1 To UBound(b, 1)
    dic(b(i, 1)) = i
  Next
 
  For i = 1 To UBound(a, 1)
    For j = 1 To UBound(a, 2)
      If a(i, j) <> "" Then
        If dic.exists(a(i, j)) Then
          wRow = dic(a(i, j))
          c(wRow, 1) = "Out"
          c(wRow, 2) = lo
          c(wRow, 3) = dt
        Else
          cad = cad & a(i, j) & vbCr
        End If
      End If
    Next
  Next
 
  sh2.Range("E2").Resize(UBound(c, 1), UBound(c, 2)).Value = c
  If cad <> "" Then
    MsgBox cad, , "Serial number was not found in inventory"
  End If
End Sub


--------------
I hope to hear from you soon.
Respectfully
Dante Amor
--------------​
 
Last edited:
Upvote 0
This works much faster however, because I can't follow the code as well, I'm not sure how to go about adding in some customization. For instance, I would like for 'lo' to have a bold font when it is entered in from the macro.
DanteAmor said:
c(wRow, 2) = lo
Click to expand...

The other immediate issue is the MsgBox seems to somehow include the header row even though the range is set to B11:O. It keeps popping up with "Serial number was not found in inventory: SERIAL NUMBERS".

I will try this again tomorrow with a much larger dataset to see how it well it handles.

Thanks again.
 
Upvote 0
Lil Stinker said:
I would like for 'lo' to have a bold font when it is entered in from the macro.
Click to expand...
ok, I add it to the macro.
-----------------

Lil Stinker said:
the MsgBox seems to somehow include the header row
Click to expand...
That is strange in my tests that text does not appear.
Is there that text again rows below?


Try this:

VBA Code: 
Sub out_serial_number()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim a As Variant, b As Variant, c As Variant
  Dim dic As Object, rng As Range
  Dim i&, j&, wRow&
  Dim dt As Date, lo As String, cad As String
  
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  Set dic = CreateObject("Scripting.Dictionary")
  
  a = sh1.Range("B11:O" & sh1.Range("B:O").Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row).Value
  b = sh2.Range("B2:B" & sh2.Range("B" & Rows.Count).End(3).Row).Value
  c = sh2.Range("E2:G" & sh2.Range("B" & Rows.Count).End(3).Row).Value
  Set rng = sh2.Range("F1")
  
  dt = sh1.Range("A1").Value
  lo = sh1.Range("H1").Value
  
  For i = 1 To UBound(b, 1)
    dic(b(i, 1)) = i
  Next
  
  For i = 1 To UBound(a, 1)
    For j = 1 To UBound(a, 2)
      If a(i, j) <> "" Then
        If dic.exists(a(i, j)) Then
          wRow = dic(a(i, j))
          c(wRow, 1) = "Out"
          c(wRow, 2) = lo
          c(wRow, 3) = dt
          Set rng = Union(rng, sh2.Range("F" & wRow + 1))
        Else
          cad = cad & a(i, j) & vbCr
        End If
      End If
    Next
  Next
  
  sh2.Range("E2").Resize(UBound(c, 1), UBound(c, 2)).Value = c
  rng.Font.Bold = True
  sh2.Range("F1").Font.Bold = False
  If cad <> "" Then
    cad = Replace(cad, "SERIAL NUMBERS" & vbCr, "")
    MsgBox cad, , "Serial number was not found in inventory"
  End If
End Sub


Comment how long the macro takes with all the records.
:cool:
 
Upvote 0
I've filled out my entire range (1200 cells) with serial numbers and the code runs everything in the blink of an eye! That's pretty amazing!

Just a couple minor issues:
1. I realize now why SERIAL NUMBERS was coming up in the MsgBox. You are correct, the issue doesn't present with the test workbook. It's in my actual workbook where I realize I have duplicated the header row BELOW the range as well. That is where it is grabbing SERIAL NUMBERS from. Your Replace code works to clear it out however, in my actual workbook, I have a few additional headers that come up in the MsgBox as well. Is there a way to fix the range to just the area between the header row and footer row? Here's a revised sample:​
Book1.xlsm
ABCDEFGHIJKLMNOPQRST
12/3/2023Date Out2/13/2023Date InLocationOC Carnival Event
2
10SERIAL NUMBERSApplesOrangesPears
110114016426444764716494551065318553757275943640765486721MB0069569MB211A322
120164017427544804717494851075320554057315945640865536722MB0079570MB212A348
130174018427944824718494951095328554257325947640965546724MB0119571MB214A349
140234019428544834720495451115331554357345948641065566725MB0279572MB215A350
7121034235444846944923509552895509569159196106652766976850MB176MB284A272MB382
7221074243444947004924509752905515569859206108653166986851MB177MB285A273MB383
7340084244445447014927509952965519571459236110653566996854MB179MB287A274MB384
7440104254446147094929510053015521571659246113653767016855MB180079A278MB385
7540114256446647114932510253025531571959346114653867046857MB183MB001A279MB386
7640134259446747124938510453135532572059396115654067066858MB184MB002A285MB387
7740154263446947144941510553175533572459406116654467096860MB185MB003A287MB388
78SERIAL NUMBERSApplesOrangesPears
Sheet1
​
2. Do you know why this happens if I run this macro while having the data filtered on Sheet2? If I filter the data to show only what is "Out" in Column E and run the macro, this is what happens. If I clear the filter and run it again, it corrects itself.​
1686879109844.png
 
Upvote 0
Lil Stinker said:
I would like for 'lo' to have a bold font
Click to expand...

Lil Stinker said:
I have duplicated the header row BELOW the range as well.
Click to expand...

Lil Stinker said:
while having the data filtered on Sheet2?
Click to expand...
Here is the macro with the changes:

VBA Code: 
Sub out_serial_number()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim a As Variant, b As Variant, c As Variant
  Dim dic As Object, rng As Range
  Dim i&, j&, wRow&
  Dim dt As Date, lo As String, cad As String
  Dim f As Range
  
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  Set dic = CreateObject("Scripting.Dictionary")
  If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
  If sh2.AutoFilterMode Then sh2.AutoFilterMode = False
  sh1.Cells.EntireRow.Hidden = False
  sh2.Cells.EntireRow.Hidden = False
  
  Set f = sh1.Range("B:B").Find("SERIAL NUMBERS", , xlValues, xlWhole, xlByRows, xlPrevious, False)
  a = sh1.Range("B11:O" & f.Row - 1).Value
  b = sh2.Range("B2:B" & sh2.Range("B" & Rows.Count).End(3).Row).Value
  c = sh2.Range("E2:G" & sh2.Range("B" & Rows.Count).End(3).Row).Value
  Set rng = sh2.Range("F1")
  
  dt = sh1.Range("A1").Value
  lo = sh1.Range("H1").Value
  
  For i = 1 To UBound(b, 1)
    dic(b(i, 1)) = i
  Next
  
  For i = 1 To UBound(a, 1)
    For j = 1 To UBound(a, 2)
      If a(i, j) <> "" Then
        If dic.exists(a(i, j)) Then
          wRow = dic(a(i, j))
          c(wRow, 1) = "Out"
          c(wRow, 2) = lo
          c(wRow, 3) = dt
          Set rng = Union(rng, sh2.Range("F" & wRow + 1))
        Else
          cad = cad & a(i, j) & vbCr
        End If
      End If
    Next
  Next
  
  sh2.Range("E2").Resize(UBound(c, 1), UBound(c, 2)).Value = c
  rng.Font.Bold = True
  sh2.Range("F1").Font.Bold = False
  If cad <> "" Then
    MsgBox cad, , "Serial number was not found in inventory"
  End If
End Sub

:cool:
 
Upvote 0
Solution
Using Dictionary is a very fast method. I am curious if using arrays would be any faster:
VBA Code: 
Sub out_serial_number_v2()
  Dim sht1 As Variant, sht2 As Variant
  Dim dt As Date, lo As String, cad As String
 
  With Worksheets("Sheet1")
  sht1 = .Range("B11:O" & .Cells(Rows.Count, 2).End(xlUp).Row & "")
  dt = .Range("A1").Value
  lo = .Range("H1").Value
  End With
  With Worksheets("Sheet2")
  sht2 = .Range("B1:G" & .Cells(Rows.Count, 2).End(xlUp).Row & "")
  End With
  For Each c In sht1
    For i = 1 To UBound(sht2)
      If sht2(i, 1) = c Then
        sht2(i, 4) = "OUT"
        sht2(i, 5) = lo
        sht2(i, 6) = dt
      Else
        cad = cad & c & vbCr
      End If
    Next
  Next
  Worksheets("Sheet2").Range("B1").Resize(UBound(sht2, 1), UBound(sht2, 2)) = sht2
  If cad <> "" Then
    MsgBox cad, , "Serial number was not found in inventory"
  End If
End Sub
 
Upvote 0
DanteAmor said:
Here is the macro with the changes:

VBA Code: 
Sub out_serial_number()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim a As Variant, b As Variant, c As Variant
  Dim dic As Object, rng As Range
  Dim i&, j&, wRow&
  Dim dt As Date, lo As String, cad As String
  Dim f As Range
 
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  Set dic = CreateObject("Scripting.Dictionary")
  If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
  If sh2.AutoFilterMode Then sh2.AutoFilterMode = False
  sh1.Cells.EntireRow.Hidden = False
  sh2.Cells.EntireRow.Hidden = False
 
  Set f = sh1.Range("B:B").Find("SERIAL NUMBERS", , xlValues, xlWhole, xlByRows, xlPrevious, False)
  a = sh1.Range("B11:O" & f.Row - 1).Value
  b = sh2.Range("B2:B" & sh2.Range("B" & Rows.Count).End(3).Row).Value
  c = sh2.Range("E2:G" & sh2.Range("B" & Rows.Count).End(3).Row).Value
  Set rng = sh2.Range("F1")
 
  dt = sh1.Range("A1").Value
  lo = sh1.Range("H1").Value
 
  For i = 1 To UBound(b, 1)
    dic(b(i, 1)) = i
  Next
 
  For i = 1 To UBound(a, 1)
    For j = 1 To UBound(a, 2)
      If a(i, j) <> "" Then
        If dic.exists(a(i, j)) Then
          wRow = dic(a(i, j))
          c(wRow, 1) = "Out"
          c(wRow, 2) = lo
          c(wRow, 3) = dt
          Set rng = Union(rng, sh2.Range("F" & wRow + 1))
        Else
          cad = cad & a(i, j) & vbCr
        End If
      End If
    Next
  Next
 
  sh2.Range("E2").Resize(UBound(c, 1), UBound(c, 2)).Value = c
  rng.Font.Bold = True
  sh2.Range("F1").Font.Bold = False
  If cad <> "" Then
    MsgBox cad, , "Serial number was not found in inventory"
  End If
End Sub

:cool:
Click to expand...
Dante, you're a maestro! Works like a charm! Speed: 0.05 seconds

Just one more thing and I'm not sure if it requires a separate post. How can I go about reversing this process if the user needs to remove serial numbers after they've been recorded to Sheet2? Reversing it meaning, changing c(wRow, 1) = "IN" and clearing out lo and dt when the serial number is deleted on Sheet1. Would this require a separate sub with a designed pop-up Delete button or is there some way of catching the delete event when using the Backspace or Delete button on the keyboard?
 
Upvote 0
Flashbond said:
Using Dictionary is a very fast method. I am curious if using arrays would be any faster:
VBA Code: 
Sub out_serial_number_v2()
  Dim sht1 As Variant, sht2 As Variant
  Dim dt As Date, lo As String, cad As String
 
  With Worksheets("Sheet1")
  sht1 = .Range("B11:O" & .Cells(Rows.Count, 2).End(xlUp).Row & "")
  dt = .Range("A1").Value
  lo = .Range("H1").Value
  End With
  With Worksheets("Sheet2")
  sht2 = .Range("B1:G" & .Cells(Rows.Count, 2).End(xlUp).Row & "")
  End With
  For Each c In sht1
    For i = 1 To UBound(sht2)
      If sht2(i, 1) = c Then
        sht2(i, 4) = "OUT"
        sht2(i, 5) = lo
        sht2(i, 6) = dt
      Else
        cad = cad & c & vbCr
      End If
    Next
  Next
  Worksheets("Sheet2").Range("B1").Resize(UBound(sht2, 1), UBound(sht2, 2)) = sht2
  If cad <> "" Then
    MsgBox cad, , "Serial number was not found in inventory"
  End If
End Sub
Click to expand...
Flashbond, I'm having a little trouble with your code. I'm not sure how to Dim c or i with yours. When I remove Option Explicit, it crashes. Please advise. I'm curious to test it as well.
 
Upvote 0
You may dim i as long and dim c as variant. But it will be nowhere near to @DanteAmor 's solution I guess. 0.05 is pretty awsome.
 
Last edited by a moderator:
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Question Question
Can scripting dictionary alert if certain criteria are met?
Replies
1
Views
267
Lil Stinker
L
C
  • Question Question
Force user to enter at least one symbol and one number in a textbox through a userform
Replies
9
Views
305
christianbiker
C
youbitto
  • Solved
Index match VBA taking too long
2 3
Replies
27
Views
556
Alex Blakenburg
A
C
  • Solved
index match excel formula to vba code
Replies
9
Views
332
DanteAmor
DanteAmor
L
  • Solved
Run Dictionary Script & Find based on multiple criteria
Replies
7
Views
606
DanteAmor
DanteAmor

Forum statistics

Threads
1,223,889
Messages
6,175,224
Members
452,620
Latest member
dsubash

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top