Option Explicit
Sub Loc()
Dim Rng As Range, Cls As Range, Sh As Worksheet
Dim KHoach As Double, THien As Double, eRw As Long, fColor As Long
Dim Dat1 As Date, Dat2 As Date
Sheets("DauVao").Select: Set Sh = Sheets("DauRa")
Set Rng = Range([A5], [A65500].End(xlUp)): eRw = Rng.Rows.Count
Rng.Resize(, 4).Sort Key1:=Range("A5"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1
Set Rng = Rng.Offset(, 1)
Sh.[b8].Resize(eRw).ClearContents
Sh.[d8].Resize(eRw, 4).ClearContents '
For Each Cls In Rng
If Cls.Offset(, 1).Value > Cls.Value Then
If KHoach = 0 Then
Dat1 = Cls.Offset(, -1).Value: Dat2 = Dat1
KHoach = Cls.Value: THien = Cls.Offset(, 1).Value
fColor = 1 + fColor
Cls.Interior.ColorIndex = 34 + fColor Mod 6
ElseIf Cls.Value = KHoach And THien = Cls.Offset(, 1).Value Then
Dat2 = Cls.Offset(, -1).Value
Cls.Interior.ColorIndex = 34 + fColor Mod 6
ElseIf Cls.Value <> KHoach Or THien <> Cls.Offset(, 1).Value Then
Cls.Offset(-1).Interior.ColorIndex = 34 + fColor Mod 6
fColor = 1 + fColor
Cls.Interior.ColorIndex = 34 + fColor Mod 6
With Sh.[b65500].End(xlUp).Offset(1)
.Value = "From " & CStr(Dat1) & " to " & CStr(Dat2)
.Offset(, 2).Value = THien
.Offset(, 3).Value = KHoach
.Offset(, 4).Value = THien - KHoach
.Offset(, 5).Value = 1 + Dat2 - Dat1
End With
Dat1 = Cls.Offset(, -1).Value: Dat2 = Dat1
KHoach = Cls.Value: THien = Cls.Offset(, 1).Value
End If
Else
KHoach = 0
End If
Next Cls
Sh.Select
End Sub
