Speed up Find

S

Scoti

New Member
Joined
Nov 8, 2020
Messages
39
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

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.
Sort by date Sort by votes
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:
Upvote 0
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?
 
Upvote 0
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.
 
Upvote 0
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
 
Upvote 0
Solution
DanteAmor said:
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?
Click to expand...
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.
 
Upvote 0
DanteAmor said:
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
Click to expand...
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.
 
Upvote 0
DanteAmor said:
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
Click to expand...
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?
 
Upvote 0
Scoti said:
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.
Click to expand...


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.
 
Upvote 0
DanteAmor said:
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.
Click to expand...
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?
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
Combine two codes in one worksheet change events
Replies
3
Views
250
Alex Blakenburg
A
I
  • Solved
Code in use selects cell but i am unable to then click out of cell
Replies
2
Views
282
ipbr21054
I
F
  • Solved
Looping code sequence
Replies
5
Views
137
FrenchCelt
F
G
  • Solved
Add total row with a loop
Replies
4
Views
127
gberg
G
I
  • Question
Once cell is selected i am unable to tab out of cell unless i use the mouse.
Replies
2
Views
238
ipbr21054
I

Forum statistics

Threads
1,214,601
Messages
6,120,465
Members
448,965
Latest member
grijken

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