Option Explicit
Sub HD06()
Dim Rng As Range, sRng As Range
Dim MyAdd As String, nDat As Integer, Than As Integer
Dim SoDat As Double, SoThan As Double
Sheets("DataT1").Select
Set Rng = Range([c2], [c65500].End(xlUp))
Set sRng = Rng.Find("HD 06", , xlFormulas, xlPart)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
If sRng.Offset(, 2).Value > 0 Then
sRng.Resize(, 2).Interior.ColorIndex = 36
[h65500].End(xlUp).Offset(1).Value = sRng.Address
[I65500].End(xlUp).Offset(1).Value = sRng.Offset(, 2).Value
End If
If sRng.Offset(, 3).Value > 0 Then
sRng.Resize(, 3).Interior.ColorIndex = 38
[J65500].End(xlUp).Offset(1).Value = sRng.Address
[K65500].End(xlUp).Offset(1).Value = sRng.Offset(, 3).Value
End If
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
End Sub
