VBA Find Loop takes too long

Lil Stinker · Jun 14, 2023

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

DanteAmor · Jun 14, 2023

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
--------------

Lil Stinker · Jun 14, 2023

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

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.

DanteAmor · Jun 15, 2023

Lil Stinker said:
I would like for 'lo' to have a bold font when it is entered in from the macro.

ok, I add it to the macro.
-----------------

Lil Stinker said:
the MsgBox seems to somehow include the header row

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.

Lil Stinker · Jun 15, 2023

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

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

1

2/3/2023

Date Out

2/13/2023

Date In

Location

OC Carnival Event

2

10

SERIAL NUMBERS

Apples

Oranges

Pears

11

011

4016

4264

4476

4716

4945

5106

5318

5537

5727

5943

6407

6548

6721

MB006

9569

MB211

A322

12

016

4017

4275

4480

4717

4948

5107

5320

5540

5731

5945

6408

6553

6722

MB007

9570

MB212

A348

13

017

4018

4279

4482

4718

4949

5109

5328

5542

5732

5947

6409

6554

6724

MB011

9571

MB214

A349

14

023

4019

4285

4483

4720

4954

5111

5331

5543

5734

5948

6410

6556

6725

MB027

9572

MB215

A350

71

2103

4235

4448

4694

4923

5095

5289

5509

5691

5919

6106

6527

6697

6850

MB176

MB284

A272

MB382

72

2107

4243

4449

4700

4924

5097

5290

5515

5698

5920

6108

6531

6698

6851

MB177

MB285

A273

MB383

73

4008

4244

4454

4701

4927

5099

5296

5519

5714

5923

6110

6535

6699

6854

MB179

MB287

A274

MB384

74

4010

4254

4461

4709

4929

5100

5301

5521

5716

5924

6113

6537

6701

6855

MB180

079

A278

MB385

75

4011

4256

4466

4711

4932

5102

5302

5531

5719

5934

6114

6538

6704

6857

MB183

MB001

A279

MB386

76

4013

4259

4467

4712

4938

5104

5313

5532

5720

5939

6115

6540

6706

6858

MB184

MB002

A285

MB387

77

4015

4263

4469

4714

4941

5105

5317

5533

5724

5940

6116

6544

6709

6860

MB185

MB003

A287

MB388

78

SERIAL NUMBERS

Apples

Oranges

Pears

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.

DanteAmor · Jun 15, 2023

Lil Stinker said:
I would like for 'lo' to have a bold font

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

Lil Stinker said:
while having the data filtered on Sheet2?

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

Legacy 143009 · Jun 16, 2023

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

Lil Stinker · Jun 16, 2023

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

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?

Lil Stinker · Jun 16, 2023

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

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.

Legacy 143009 · Jun 16, 2023

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.

VBA Find Loop takes too long

Lil Stinker

Board Regular

Excel Facts

DanteAmor

Well-known Member

Lil Stinker

Board Regular

DanteAmor

Well-known Member

Lil Stinker

Board Regular

DanteAmor

Well-known Member

Legacy 143009

Guest

Lil Stinker

Board Regular

Lil Stinker

Board Regular

Legacy 143009

Guest

Similar threads

Forum statistics

Share this page

VBA Find Loop takes too long

Board Regular

Excel Facts

Well-known Member

Board Regular

Well-known Member

Board Regular

Well-known Member

Legacy 143009

Guest

Board Regular

Board Regular

Legacy 143009

Guest

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock