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
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,582
Office Version
  1. 2007
Platform
  1. Windows
Change this line:
VBA Code:
For Each cell In Sheets("Retest").Range("C2:C50")

For this line:
VBA Code:
For Each cell In Sheets("Retest").Range("C2:C50").SpecialCells(xlCellTypeConstants)
 

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop

Scoti

New Member
Joined
Nov 8, 2020
Messages
35
Office Version
  1. 2010
Platform
  1. Windows
Change this line:
VBA Code:
For Each cell In Sheets("Retest").Range("C2:C50")

For this line:
VBA Code:
For Each cell In Sheets("Retest").Range("C2:C50").SpecialCells(xlCellTypeConstants)
That worked perfectly. Thank you for all your help. The improvement in speed is amazing!
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,582
Office Version
  1. 2007
Platform
  1. Windows
I'm glad to help you. Thanks for the feedback.
 

Forum statistics

Threads
1,141,286
Messages
5,705,517
Members
421,399
Latest member
hjweiss00

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