I have a loop set up to Loop Unitl c = "". However, there are 20,000 reocrds and its taking a long time. So I have sorted them by the "c" value.
How can I rewrite this loop to Loop Until c in different?
Here's the full macro:
Sub ProductServiceBoth()
Application.ScreenUpdating = False
Dim FirstValue, SecondValue, LastAddress, ThirdValue As String
Dim Cel As Range
Dim c As Object
For Each Cel In Selection
Set c = Worksheets("Sheet2").Columns("A:A").Find(Worksheets("Sheet1").Range(Cel.Address).Value, LookIn:=xlWhole, SearchOrder:=xlByColumns)
FirstValue = Worksheets("Sheet2").Range(c.Address).Offset(0, 3).Value
Set c = Worksheets("Sheet2").Columns("A:A").FindNext(c)
SecondValue = Worksheets("Sheet2").Range(c.Address).Offset(0, 3).Value
If FirstValue <> SecondValue Then
Worksheets("Sheet1").Range(Cel.Address).Offset(0, 3).Value = "Both"
GoTo 1
Else:
Do
Set c = Worksheets("Sheet2").Columns("A:A").FindNext(c)
ThirdValue = Worksheets("Sheet2").Range(c.Address).Offset(0, 3).Value
If FirstValue <> ThirdValue Then
Worksheets("Sheet1").Range(Cel.Address).Offset(0, 3).Value = "Both"
GoTo 1
End If
Loop Until c = ""
End If
1 Cel.Interior.ColorIndex = 6
Next Cel
Application.ScreenUpdating = True
MsgBox ("Done!")
Thanks
How can I rewrite this loop to Loop Until c in different?
Here's the full macro:
Sub ProductServiceBoth()
Application.ScreenUpdating = False
Dim FirstValue, SecondValue, LastAddress, ThirdValue As String
Dim Cel As Range
Dim c As Object
For Each Cel In Selection
Set c = Worksheets("Sheet2").Columns("A:A").Find(Worksheets("Sheet1").Range(Cel.Address).Value, LookIn:=xlWhole, SearchOrder:=xlByColumns)
FirstValue = Worksheets("Sheet2").Range(c.Address).Offset(0, 3).Value
Set c = Worksheets("Sheet2").Columns("A:A").FindNext(c)
SecondValue = Worksheets("Sheet2").Range(c.Address).Offset(0, 3).Value
If FirstValue <> SecondValue Then
Worksheets("Sheet1").Range(Cel.Address).Offset(0, 3).Value = "Both"
GoTo 1
Else:
Do
Set c = Worksheets("Sheet2").Columns("A:A").FindNext(c)
ThirdValue = Worksheets("Sheet2").Range(c.Address).Offset(0, 3).Value
If FirstValue <> ThirdValue Then
Worksheets("Sheet1").Range(Cel.Address).Offset(0, 3).Value = "Both"
GoTo 1
End If
Loop Until c = ""
End If
1 Cel.Interior.ColorIndex = 6
Next Cel
Application.ScreenUpdating = True
MsgBox ("Done!")
Thanks