Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim I As Long, ClNum As Long, RngFrstCl As Long, C As Long, Cl As Long, ClOfst As Long, N As Long, Md As Long, D As Long, P As Single, CN As Long, RN As Long, Ar As Long
Dim Rngyy As Range, AC As Range, Rng As Range, DateRng As Range, FrstRng As Range, LstRng As Range, CondRngNew As Range, CondRngOld As Range, FrstCllOld As Range
Dim FrstCllNew As Range, LstCllNew As Range, LstCllOld As Range, Cll As Range
Dim CondRngNewAdrs As String, CondRngOldAdrs As String, V As String, FrstRngAdrs As String, LstRngAdrs As String
Dim ArrRng As Variant, ArrFC As Variant, ArrLC As Variant
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
Set Rngyy = Range("H1")
If Intersect(Target, Cells) Is Nothing Then Exit Sub
If Not Intersect(Target, Columns("B:G")) Is Nothing Then
Set AC = ActiveCell
For I = 1 To 2
Application.Undo
RngFrstCl = WorksheetFunction.Ceiling(Target.Columns.Count, 2) / 2 ' First Column of Date Range
For C = 1 To RngFrstCl
Set DateRng = Target.Columns((C * 2) - 1).Cells
For Each Rng In DateRng
ClNum = (Rng.Column - Columns("B:G").Column) + 1 'Range Column N0.
If ClNum Mod 2 = 0 Then
FrstRngAdrs = FrstRngAdrs & IIf(FrstRngAdrs <> "", ",", "") & Cells(Rng.Row, Rng.Column - 1).Address
Set FrstRng = Range(FrstRngAdrs)
LstRngAdrs = LstRngAdrs & IIf(LstRngAdrs <> "", ",", "") & Rng.Address
Set LstRng = Range(LstRngAdrs)
If I = 1 Then
ClOfst = ((Year(Cells(Rng.Row, Rng.Column - 1).Value) - Rngyy.Value) * 12) + Month(Cells(Rng.Row, Rng.Column - 1).Value) + Rngyy.Column - 1
Cl = ((Year(Rng.Value) - Rngyy.Value) * 12) + Month(Rng.Value) + Rngyy.Column
CN = IIf(Cl - ClOfst > 0, Cl - ClOfst, 1)
If Rng.Value <> "" Then
CondRngOldAdrs = CondRngOldAdrs & IIf(CondRngOldAdrs <> "", ",", "") & Cells(Rng.Row, ClOfst).Resize(1, CN).Address
Set CondRngOld = Range(CondRngOldAdrs)
Set FrstCllOld = CondRngOld.Cells(1, 1)
Set LstCllOld = CondRngOld.Cells(1, CondRngOld.Columns.Count)
End If
Else
ClOfst = ((Year(Cells(Rng.Row, Rng.Column - 1).Value) - Rngyy.Value) * 12) + Month(Cells(Rng.Row, Rng.Column - 1).Value) + Rngyy.Column - 1
Cl = ((Year(Rng.Value) - Rngyy.Value) * 12) + Month(Rng.Value) + Rngyy.Column
CN = IIf(Cl - ClOfst > 0, Cl - ClOfst, 1)
If Rng.Value <> "" Then
CondRngNewAdrs = CondRngNewAdrs & IIf(CondRngNewAdrs <> "", ",", "") & Cells(Rng.Row, ClOfst).Resize(1, CN).Address
Set CondRngNew = Range(CondRngNewAdrs)
End If
End If
Else
FrstRngAdrs = FrstRngAdrs & IIf(FrstRngAdrs <> "", ",", "") & Rng.Address
Set FrstRng = Range(FrstRngAdrs)
LstRngAdrs = LstRngAdrs & IIf(LstRngAdrs <> "", ",", "") & Cells(Rng.Row, Rng.Column + 1).Address
Set LstRng = Range(LstRngAdrs)
If I = 1 Then
Cl = ((Year(Rng.Value) - Rngyy.Value) * 12) + Month(Rng.Value) + Rngyy.Column - 1
ClOfst = ((Year(Cells(Rng.Row, Rng.Column + 1).Value) - Rngyy.Value) * 12) + Month(Cells(Rng.Row, Rng.Column + 1).Value) + Rngyy.Column
CN = IIf(ClOfst - Cl > 0, ClOfst - Cl, 1)
If Rng.Value <> "" Then
CondRngOldAdrs = CondRngOldAdrs & IIf(CondRngOldAdrs <> "", ",", "") & Cells(Rng.Row, Cl).Resize(1, CN).Address
Set CondRngOld = Range(CondRngOldAdrs)
End If
Else
Cl = ((Year(Rng.Value) - Rngyy.Value) * 12) + Month(Rng.Value) + Rngyy.Column - 1
ClOfst = ((Year(Cells(Rng.Row, Rng.Column + 1).Value) - Rngyy.Value) * 12) + Month(Cells(Rng.Row, Rng.Column + 1).Value) + Rngyy.Column
CN = IIf(ClOfst - Cl > 0, ClOfst - Cl, 1)
If Rng.Value <> "" Then
CondRngNewAdrs = CondRngNewAdrs & IIf(CondRngNewAdrs <> "", ",", "") & Cells(Rng.Row, Cl).Resize(1, CN).Address
Set CondRngNew = Range(CondRngNewAdrs)
End If
End If
RN = Rng.Row
End If 'If ClNum Mod
If C = 1 Then
Else
End If
Next 'Rng
Next C
Next I
If Not CondRngOld Is Nothing Then
For Each Cll In CondRngOld
With Cll
.Interior.Pattern = xlNone
.ClearContents
End With
Next Cll
End If
ArrFC = Split(FrstRng.Address, ",")
ArrLC = Split(LstRng.Address, ",")
If Not CondRngNew Is Nothing Then
ArrRng = Split(CondRngNew.Address, ",")
For Ar = LBound(ArrRng) To UBound(ArrRng)
For Each Cll In Range(ArrRng(Ar))
With Cll
I = (WorksheetFunction.Ceiling((Range(ArrFC(Ar)).Column - Columns("B:G").Column), 2) / 2) ' Color Index
'I = WorksheetFunction.Ceiling((Range(ArrLC(Ar)).Column - Columns("B:G").Column), 2) / 2 ' Color Index
If Cll.Address = Range(ArrRng(Ar)).Cells(1, 1).Address Then
Cll.Value = Day(Range(ArrFC(Ar)).Value)
FrstCllClr Cll, FrstRng(Cll.Row - CondRngNew.Row + 1).Value, I
ElseIf Cll.Address = Range(ArrRng(Ar)).Cells(Range(ArrRng(Ar)).Rows.Count, Range(ArrRng(Ar)).Columns.Count).Address Then
Cll.Value = Day(Range(ArrLC(Ar)).Value)
LstCllClr Cll, LstRng(Cll.Row - CondRngNew.Row + 1).Value, I
Else
InBtnCllClr Cll, I
End If
End With
Next Cll
Next Ar
End If
AC.Activate
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
On Error GoTo 0
End Sub
Public Sub FrstCllClr(Cll As Range, RngDate As Date, ClrIndx As Long)
Dim Md As Long, D As Long, P As Single
Dim ClrArr As Variant
Dim Clr1 As Long, Clr2 As Long, Clr3 As Long
Md = Day(DateSerial(Year(RngDate), Month(RngDate) + 1, 1) - 1)
D = Day(RngDate)
P = 1 - Round(D / Md, 2)
Clr1 = RGB(255, 137, 137)
Clr2 = RGB(170, 210, 140)
Clr3 = RGB(0, 173, 234)
ClrArr = Array(Clr1, Clr2, Clr3)
With Cll.Interior
.Pattern = xlPatternLinearGradient
.Gradient.Degree = 180
.Gradient.ColorStops.Clear
.Gradient.ColorStops.Add(0).Color = ClrArr(ClrIndx)
.Gradient.ColorStops.Add(P).Color = ClrArr(ClrIndx)
.Gradient.ColorStops.Add(P + 0.01).Color = RGB(255, 255, 255)
.Gradient.ColorStops.Add(1).Color = RGB(255, 255, 255)
End With
End Sub
Public Sub LstCllClr(Cll As Range, RngDate As Date, ClrIndx As Long)
Dim Md As Long, D As Long, P As Single
Dim ClrArr As Variant
Dim Clr1 As Long, Clr2 As Long, Clr3 As Long
Md = Day(DateSerial(Year(RngDate), Month(RngDate) + 1, 1) - 1)
D = Day(RngDate)
P = 1 - Round(D / Md, 2)
Clr1 = RGB(255, 137, 137)
Clr2 = RGB(170, 210, 140)
Clr3 = RGB(0, 173, 234)
ClrArr = Array(Clr1, Clr2, Clr3)
With Cll.Interior
.Pattern = xlPatternLinearGradient
.Gradient.Degree = 180
.Gradient.ColorStops.Clear
.Gradient.ColorStops.Add(0).Color = RGB(255, 255, 255)
.Gradient.ColorStops.Add(P).Color = RGB(255, 255, 255)
.Gradient.ColorStops.Add(P + 0.01).Color = ClrArr(ClrIndx)
.Gradient.ColorStops.Add(1).Color = ClrArr(ClrIndx)
End With
End Sub
Public Sub InBtnCllClr(Cll As Range, ClrIndx As Long)
Dim ClrArr As Variant
Dim Clr1 As Long, Clr2 As Long, Clr3 As Long
Clr1 = RGB(255, 137, 137)
Clr2 = RGB(170, 210, 140)
Clr3 = RGB(0, 173, 234)
ClrArr = Array(Clr1, Clr2, Clr3)
With Cll.Interior
.Pattern = xlSolid
.Color = ClrArr(ClrIndx)
End With
End Sub
