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
