Private Sub Worksheet_Change(ByVal Target As Range)
Dim LstRw As Long, PrvsLstCol As Long, CurrLstCol As Long, PrvsVal As Long, CurtVal As Long
Dim SrcRng As Range, FllRng As Range
PrvsLstCol = Cells(3, Columns.Count).End(xlToLeft).Column
LstRw = Cells(Cells.Rows.Count, PrvsLstCol).End(xlUp).Row
Dim r As Range
Application.EnableEvents = False
If Not Intersect(Target, Cells(3, PrvsLstCol)) Is Nothing Then
Application.Undo
DateVal = Cells(2, PrvsLstCol).Value
PrvsVal = Cells(3, PrvsLstCol).Value
Application.Undo
CurtVal = Cells(3, PrvsLstCol).Value
' Rest Last Column
CurrLstCol = (CurtVal * 2) + 3
'Titel
With Cells(1, 1).Resize(1, CurrLstCol)
.HorizontalAlignment = xlCenterAcrossSelection
.Interior.Color = .Cells(1, 1).Interior.Color
End With
With Cells(2, 2).Resize(1, CurrLstCol - 4)
.HorizontalAlignment = xlCenterAcrossSelection
.Interior.Color = .Cells(1, 2).Interior.Color
End With
With Cells(3, 2).Resize(1, CurrLstCol - 4)
.HorizontalAlignment = xlCenterAcrossSelection
.Interior.Color = .Cells(1, 2).Interior.Color
End With
'Date
With Cells(2, CurrLstCol)
.Value = DateVal
End With
With Cells(2, PrvsLstCol)
.Value = ""
End With
'Cycle
With Cells(3, CurrLstCol)
.Value = CurtVal
End With
With Cells(3, PrvsLstCol)
.Value = ""
End With
'
With Cells(5, PrvsLstCol).Resize(LstRw + 1 - 5, 1)
.Copy Destination:=Cells(5, CurrLstCol)
.Value = ""
End With
If CurtVal > PrvsVal Then
With Cells(5, PrvsLstCol - 2).Resize(2, 2)
.AutoFill Destination:=Cells(5, PrvsLstCol - 2).Resize(2, 2 + (CurrLstCol - PrvsLstCol))
End With
Else
With Cells(1, CurrLstCol + 1).Resize(LstRw + 1 - 1, PrvsLstCol - CurrLstCol)
.Clear
End With
End If
With Cells(7, 1).Resize(LstRw + 1 - 7, CurrLstCol)
.Cells.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=" & .Address(False, True) & "<>"""""
.FormatConditions(.FormatConditions.Count).SetFirstPriority
.FormatConditions(.FormatConditions.Count).Borders.LineStyle = xlContinuous
.FormatConditions(1).StopIfTrue = False
End With
End If
Application.EnableEvents = True
End Sub