Speed up Find

Scoti

New Member
Joined
Nov 8, 2020
Messages
35
Office Version
  1. 2010
Platform
  1. Windows
I am running the following macro and it seems very slow. The number of values to search for can vary and it searches across 7 sheets of varying numbers of used rows. Can anyone give me any suggestions on how to speed this up?
VBA Code:
Sub findSample()

    Application.Calculation = xlCalculationManual

Application.ScreenUpdating = False

Application.DisplayStatusBar = False

Application.EnableEvents = False

ActiveSheet.DisplayPageBreaks = False

 

 

    Dim FindString As String

    Dim rng As Range

    Set Sheet = Sheets("Retest")

  

    For Each cell In Range("C2:C50")

        FindString = cell.Value

      

              With Sheets("Archived").Range("$B:$B")

                Set rng = .Find(What:=FindString, _

                                After:=.Cells(.Cells.Count), _

                                LookIn:=xlValues, _

                                LookAt:=xlWhole, _

                                SearchOrder:=xlByRows, _

                                SearchDirection:=xlPrevious, _

                                MatchCase:=False)

                If Not rng Is Nothing Then

                    Application.GoTo rng, True

 

                    TheDepartment = "Archived" & " " & ActiveCell.Offset(0, 3) & "/" & ActiveCell.Offset(0, 4).Value

                    TheDate = ActiveCell.Offset(0, 5).Value

                    TheSite = ActiveCell.Offset(0, 2).Value

 

                    cell.Offset(0, 12).Value = TheDepartment

                    cell.Offset(0, 13).Value = TheDate

                    cell.Offset(0, 14).Value = TheSite

          

                    

                End If

            End With

  

             With Sheets("Received").Range("$D:$D")

                Set rng = .Find(What:=FindString, _

                                After:=.Cells(.Cells.Count), _

                                LookIn:=xlValues, _

                                LookAt:=xlWhole, _

                                SearchOrder:=xlByRows, _

                                SearchDirection:=xlPrevious, _

                                MatchCase:=False)

                If Not rng Is Nothing Then

                    Application.GoTo rng, True

 

                    TheDepartment = ActiveCell.Offset(0, -2).Value

                    TheDate = ActiveCell.Offset(0, -1).Value

                    TheSite = ActiveCell.Offset(0, 2).Value

 

                    cell.Offset(0, 12).Value = TheDepartment

                    cell.Offset(0, 13).Value = TheDate

                    cell.Offset(0, 14).Value = TheSite

          

                    

                End If

            End With

             With Sheets("Herzog_Received").Range("$D:$D")

                Set rng = .Find(What:=FindString, _

                                After:=.Cells(.Cells.Count), _

                                LookIn:=xlValues, _

                                LookAt:=xlWhole, _

                                SearchOrder:=xlByRows, _

                                SearchDirection:=xlPrevious, _

                                MatchCase:=False)

                If Not rng Is Nothing Then

                   Application.GoTo rng, True

 

                    HDepartment = ActiveCell.Offset(0, -2).Value

                    HDate = ActiveCell.Offset(0, -1).Value

                    HSite = ActiveCell.Offset(0, 2).Value

                    cell.Offset(0, 12).Value = HDepartment

                    cell.Offset(0, 13).Value = HDate

                    cell.Offset(0, 14).Value = HSite

                  

                End If

            End With

             With Sheets("Man_Received").Range("$D:$D")

                Set rng = .Find(What:=FindString, _

                                After:=.Cells(.Cells.Count), _

                                LookIn:=xlValues, _

                                LookAt:=xlWhole, _

                                SearchOrder:=xlByRows, _

                                SearchDirection:=xlPrevious, _

                                MatchCase:=False)

                If Not rng Is Nothing Then

                   Application.GoTo rng, True

 

                    MDepartment = ActiveCell.Offset(0, -2).Value

                    MDate = ActiveCell.Offset(0, -1).Value

                    MSite = ActiveCell.Offset(0, 2).Value

                    cell.Offset(0, 12).Value = MDepartment

                    cell.Offset(0, 13).Value = MDate

                    cell.Offset(0, 14).Value = MSite

                  

                End If

            End With

          

             With Sheets("L5_Received").Range("$D:$D")

                Set rng = .Find(What:=FindString, _

                                After:=.Cells(.Cells.Count), _

                                LookIn:=xlValues, _

                                LookAt:=xlWhole, _

                                SearchOrder:=xlByRows, _

                                SearchDirection:=xlPrevious, _

                                MatchCase:=False)

                If Not rng Is Nothing Then

                   Application.GoTo rng, True

 

                    L5Department = ActiveCell.Offset(0, -2).Value

                    L5Date = ActiveCell.Offset(0, -1).Value

                    L5Site = ActiveCell.Offset(0, 2).Value

                    cell.Offset(0, 12).Value = L5Department

                    cell.Offset(0, 13).Value = L5Date

                    cell.Offset(0, 14).Value = L5Site

                  

                End If

            End With

          

             With Sheets("Leco_Received").Range("$D:$D")

                Set rng = .Find(What:=FindString, _

                                After:=.Cells(.Cells.Count), _

                                LookIn:=xlValues, _

                                LookAt:=xlWhole, _

                                SearchOrder:=xlByRows, _

                                SearchDirection:=xlPrevious, _

                                MatchCase:=False)

                If Not rng Is Nothing Then

                   Application.GoTo rng, True

 

                    LecDepartment = ActiveCell.Offset(0, -2).Value

                    LecDate = ActiveCell.Offset(0, -1).Value

                    LecSite = ActiveCell.Offset(0, 2).Value

                    cell.Offset(0, 12).Value = LecDepartment

                    cell.Offset(0, 13).Value = LecDate

                    cell.Offset(0, 14).Value = LecSite

                  

                End If

            End With

          

             With Sheets("AXN_Received").Range("$D:$D")

                Set rng = .Find(What:=FindString, _

                                After:=.Cells(.Cells.Count), _

                                LookIn:=xlValues, _

                                LookAt:=xlWhole, _

                                SearchOrder:=xlByRows, _

                                SearchDirection:=xlPrevious, _

                                MatchCase:=False)

                If Not rng Is Nothing Then

                   Application.GoTo rng, True

 

                    ADepartment = ActiveCell.Offset(0, -2).Value

                    ADate = ActiveCell.Offset(0, -1).Value

                    ASite = ActiveCell.Offset(0, 2).Value

                    cell.Offset(0, 12).Value = ADepartment

                    cell.Offset(0, 13).Value = ADate

                    cell.Offset(0, 14).Value = ASite

                  

                End If

            End With

          

            

  Next

  Sheet.Activate

 

  Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

Application.DisplayStatusBar = True

Application.EnableEvents = True

ActiveSheet.DisplayPageBreaks = True

 

End Sub
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
6,791
Office Version
  1. 2019
Platform
  1. Windows
Hi,

Range.Find method normally performs quite well – I suspect your code accessing the ranges in each sheet may be a factor in its slow performance

Untested but try the following update to your code & see if there is any improvement.
I should hasten to add that I have only glanced at your code & hope I have interpreted what you are doing correctly – if there are issues though, then helpful if can place copy of your workbook with dummy data on a file sharing site like dropbox & provide a link to it - Plenty here to offer assistance.

Dave

copy BOTH codes to standard module

VBA Code:
Sub findSample()
    Dim FindString      As Variant, SheetsArr As Variant
    Dim rng             As Range
    Dim SearchColumn    As Integer
    Dim r               As Long
    Dim wsRetest        As Worksheet, ws As Worksheet
   
    Set wsRetest = ThisWorkbook.Worksheets("Retest")
   
    'initialize search array
    FindString = wsRetest.Range("C2:C50").Value
   
    'initialize worksheets array
    SheetsArr = Array("Archived", "Received", "Herzog_Received", "Man_Received", _
                        "L5_Received", "Leco_Received", "AXN_Received")
   
    On Error GoTo myerror
   
    'turn events off
    EnableEvents False
   
    'loop all values in search array
    For r = 1 To UBound(FindString, 1)
       
        'check for blank cell
        If Len(FindString(r, 1)) > 0 Then
           
            'Archived sheet - search column B
            SearchColumn = 2
           
            'loop all worksheets in  array
            For Each ws In ThisWorkbook.Worksheets(SheetsArr)
           
                'clear object variable
                Set rng = Nothing
               
                'search range
                Set rng = ws.Columns(SearchColumn).Find(What:=FindString(r, 1), LookIn:=xlValues, _
                                                        LookAt:=xlWhole, SearchOrder:=xlByRows, _
                                                        SearchDirection:=xlPrevious, MatchCase:=False)
               
                If Not rng Is Nothing Then
               
                    'search value found
                    wsRetest.Cells(r + 1, "O").Value = _
                                     IIf(SearchColumn = 2, "Archived" & " " & rng.Offset(0, 3) & "/" & rng.Offset(0, 4).Value, _
                                     rng.Offset(0, -2).Value)
                   
                    wsRetest.Cells(r + 1, "P").Value = rng.Offset(0, IIf(SearchColumn = 2, 5, -1)).Value
                   
                    wsRetest.Cells(r + 1, "Q").Value = rng.Offset(0, 2).Value
                   
                    'exit loop
                    Exit For
                   
                End If
               
                'all other sheets search column D
                SearchColumn = 4
               
            Next ws
        End If
    'next search value
    Next r
   
myerror:
    'turn events on
    EnableEvents True
    'inform user of an error
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

Sub EnableEvents(ByVal State As Boolean)
    With Application
        .Calculation = IIf(State, xlCalculationAutomatic, xlCalculationManual)
        .ScreenUpdating = State: .DisplayStatusBar = State
        .EnableEvents = State: .DisplayAlerts = State
    End With
End Sub
 
Last edited:

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,603
Office Version
  1. 2007
Platform
  1. Windows
What happens if the data to be searched exists on several sheets? What should the code do, keep the data from the first record found, or the last record found?

According to your code, does the "Archived" sheet have a different structure?
 

jkpieterse

Well-known Member
Joined
Dec 3, 2007
Messages
1,136
Have you considered an entirely different approach: autofilter the sheet for the text, then set the values of all columns by stepping through just the visible rows.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,603
Office Version
  1. 2007
Platform
  1. Windows

ADVERTISEMENT

Check if the following code has better performance.

VBA Code:
Sub findSample()
  Dim sh As Variant, xsh As Variant
  Dim cell As Range, f As Range

  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  
  sh = Array("Received", "Herzog_Received", "Man_Received", "L5_Received", "Leco_Received", "AXN_Received")
  For Each cell In Sheets("Retest").Range("C2:C50")
    Set f = Sheets("Archived").Range("B:B").Find(cell.Value, , xlValues, xlWhole, xlByRows, xlPrevious, False)
    If Not f Is Nothing Then
      cell.Offset(0, 12).Resize(1, 3).Value = Array("Archived " & f.Offset(0, 3) & "/" & f.Offset(0, 4).Value, f.Offset(0, 5).Value, f.Offset(0, 2).Value)
    Else
      For Each xsh In sh
        Set f = Sheets(xsh).Range("D:D").Find(cell.Value, , xlValues, xlWhole, xlByRows, xlPrevious, False)
        If Not f Is Nothing Then
          cell.Offset(0, 12).Resize(1, 3).Value = Array(f.Offset(0, -2).Value, f.Offset(0, -1).Value, f.Offset(0, 2).Value)
          Exit For
        End If
      Next xsh
    End If
  Next cell
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationAutomatic
End Sub
 
Solution

Scoti

New Member
Joined
Nov 8, 2020
Messages
35
Office Version
  1. 2010
Platform
  1. Windows
What happens if the data to be searched exists on several sheets? What should the code do, keep the data from the first record found, or the last record found?

According to your code, does the "Archived" sheet have a different structure?
I should have noted that the data can not be on multiple sheets. Also, yes unfortunately the Archived sheet is structured a bit differently. I will try another users suggestion and see if it is faster. Thank you for your response. I have learned so much from forums like this.
 

Scoti

New Member
Joined
Nov 8, 2020
Messages
35
Office Version
  1. 2010
Platform
  1. Windows

ADVERTISEMENT

Check if the following code has better performance.

VBA Code:
Sub findSample()
  Dim sh As Variant, xsh As Variant
  Dim cell As Range, f As Range

  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
 
  sh = Array("Received", "Herzog_Received", "Man_Received", "L5_Received", "Leco_Received", "AXN_Received")
  For Each cell In Sheets("Retest").Range("C2:C50")
    Set f = Sheets("Archived").Range("B:B").Find(cell.Value, , xlValues, xlWhole, xlByRows, xlPrevious, False)
    If Not f Is Nothing Then
      cell.Offset(0, 12).Resize(1, 3).Value = Array("Archived " & f.Offset(0, 3) & "/" & f.Offset(0, 4).Value, f.Offset(0, 5).Value, f.Offset(0, 2).Value)
    Else
      For Each xsh In sh
        Set f = Sheets(xsh).Range("D:D").Find(cell.Value, , xlValues, xlWhole, xlByRows, xlPrevious, False)
        If Not f Is Nothing Then
          cell.Offset(0, 12).Resize(1, 3).Value = Array(f.Offset(0, -2).Value, f.Offset(0, -1).Value, f.Offset(0, 2).Value)
          Exit For
        End If
      Next xsh
    End If
  Next cell
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationAutomatic
End Sub
I will be trying this when I get into the office and let you know. Your code makes a lot of sense to me and should work perfectly. Thank you for taking the time to help.
 

Scoti

New Member
Joined
Nov 8, 2020
Messages
35
Office Version
  1. 2010
Platform
  1. Windows
Check if the following code has better performance.

VBA Code:
Sub findSample()
  Dim sh As Variant, xsh As Variant
  Dim cell As Range, f As Range

  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
 
  sh = Array("Received", "Herzog_Received", "Man_Received", "L5_Received", "Leco_Received", "AXN_Received")
  For Each cell In Sheets("Retest").Range("C2:C50")
    Set f = Sheets("Archived").Range("B:B").Find(cell.Value, , xlValues, xlWhole, xlByRows, xlPrevious, False)
    If Not f Is Nothing Then
      cell.Offset(0, 12).Resize(1, 3).Value = Array("Archived " & f.Offset(0, 3) & "/" & f.Offset(0, 4).Value, f.Offset(0, 5).Value, f.Offset(0, 2).Value)
    Else
      For Each xsh In sh
        Set f = Sheets(xsh).Range("D:D").Find(cell.Value, , xlValues, xlWhole, xlByRows, xlPrevious, False)
        If Not f Is Nothing Then
          cell.Offset(0, 12).Resize(1, 3).Value = Array(f.Offset(0, -2).Value, f.Offset(0, -1).Value, f.Offset(0, 2).Value)
          Exit For
        End If
      Next xsh
    End If
  Next cell
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationAutomatic
End Sub
Your solution worked fabulously! I put a timer message box on the old code & it ran in 40 seconds. Then I replaced it with your code and it ran in 13 seconds! Much better!!! The only thing I am having now is it is putting the word "Archived" in rows where there was no data to be searched for in the Retest sheet. I have studied your code some but can't seem to figure out how to change that so it only returns values if there is something to search for. Again this is only happening with the "Archived" find. Any ideas?
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,603
Office Version
  1. 2007
Platform
  1. Windows
The only thing I am having now is it is putting the word "Archived" in rows where there was no data to be searched for in the Retest sheet. I have studied your code some but can't seem to figure out how to change that so it only returns values if there is something to search for.


Sheets("Retest").Range("C2:C50")

Help me understand what you need. You mean that in the data range from cell C2 to C50 there are empty cells. In that case what do you want to do?

Or in the cell range A2 to A50 there is a data, for example: "asdfg" and that data does not exist in any of the sheets. In this case what do you want to do?

Or if it is not the above, you can explain it with examples.
 

Scoti

New Member
Joined
Nov 8, 2020
Messages
35
Office Version
  1. 2010
Platform
  1. Windows
Sheets("Retest").Range("C2:C50")

Help me understand what you need. You mean that in the data range from cell C2 to C50 there are empty cells. In that case what do you want to do?

Or in the cell range A2 to A50 there is a data, for example: "asdfg" and that data does not exist in any of the sheets. In this case what do you want to do?

Or if it is not the above, you can explain it with examples.
Yes, sometimes not every cell in C2:C50 will be filled. I guess what I need is the code modified so that it only searches the non-empty cells in C2:C50? Right now it is returning "Archived" as the found location adjacent to the blank cells. Does that make sense?
 

Forum statistics

Threads
1,141,413
Messages
5,706,301
Members
421,441
Latest member
VapesRub

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
Top