Option Explicit
Sub Search2()
Dim Rng As Range, Clls As Range, sRng As Range
Dim dTranS As Double: Dim DgD As Byte
Dim Sh As Worksheet: Dim MyAdd As String, sTranS As String
Application.ScreenUpdating = False: Set Sh = Sheets("FA Detail")
Sh.[A3].CurrentRegion.ClearFormats
Xep2 Sh, Sh.[b2]
Sheets("Transit").Select
Xep2 Sheets("Transit"), Sheets("Transit").[a2]
Set Rng = Range([a2], [A65500].End(xlUp))
Sh.[A3].CurrentRegion.ClearFormats
For Each Clls In Sh.Range(Sh.[b2], Sh.[b65500].End(xlUp))
Set sRng = Rng.Find(Clls.Value, LookIn:=xlFormulas, lookat:=xlWhole)
If sRng Is Nothing Then
Clls.Offset(, 5).Interior.ColorIndex = 6
Else
If Clls.Value <> Clls.Offset(-1).Value Then
Clls.Offset(, 5).Value = "'" & sRng.Offset(, 1).Value
Set sRng = Nothing
Else
dTranS = Format(sRng.Offset(, 2).Value, "#.##0")
MyAdd = sRng.Address
Do
Set sRng = Rng.FindNext(sRng)
If Format(sRng.Offset(, 2).Value, "#.##0") <> dTranS Then
Clls.Offset(, 5).Value = "'" & sRng.Offset(, 1).Value
Clls.Offset(, 5).Interior.ColorIndex = 35
Exit Do
Else
sTranS = "'" & sRng.Offset(, 1).Value
End If
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
If Clls.Offset(, 5).Value = "" Then
Clls.Offset(, 5).Value = sTranS: sTranS = ""
Clls.Offset(, 5).Interior.ColorIndex = 39
End If
End If
End If
Next Clls
Sh.Select: Set Sh = Nothing
End Sub