Sub MakeGrid_v2()
Dim StartNum As Long, Levels As Long, GridSize As Long, Counter As Long, r As Long, c As Long
Dim StartDate As Date
Dim a As Variant
Dim sMiddle As String
Const CF1 As String = "=OR(AND($E$2<>"""",ISNUMBER(FIND($E$2&CHAR(10),A8))),ISNUMBER(FIND(CHAR(10)&TEXT($E$3,""dd/mm/yyyy""),A8)))"
Const CF2 As String = "=OR(ROW(A8)=ROW(#),COLUMN(A8)=COLUMN(#))"
Const CF3 As String = "=ABS(ROW(A8)-ROW(#))=ABS(COLUMN(A8)-COLUMN(#))"
StartNum = Range("B2").Value
Levels = Range("B3").Value
StartDate = Range("B4").Value
Application.ScreenUpdating = False
With ActiveSheet.UsedRange.Offset(6)
.ClearContents
.FormatConditions.Delete
End With
GridSize = 2 * Levels + 1
ReDim a(1 To GridSize, 1 To GridSize)
r = GridSize / 2 + 0.5
c = r
Do
a(r, c) = StartNum & Chr(10) & Format(StartDate, "dd/mm/yyyy")
StartNum = StartNum + 1
StartDate = StartDate + 1
Counter = Counter + 1
Select Case True
Case a(r - 1, c) = "" And a(r, c + 1) <> ""
r = r - 1
Case a(r, c + 1) = "" And a(r + 1, c) <> ""
c = c + 1
Case a(r + 1, c) = "" And a(r, c - 1) <> ""
r = r + 1
Case Else
c = c - 1
End Select
Loop Until Counter = (GridSize - 2) ^ 2
With Range("A7").Resize(UBound(a, 1), UBound(a, 2))
.Value = a
.HorizontalAlignment = xlCenter
.Columns(1).Delete Shift:=xlToLeft
End With
With Range("A8").CurrentRegion
.Cells(1).Select
sMiddle = .Cells(.Rows.Count / 2 + 0.5, .Columns.Count / 2 + 0.5).Address
.FormatConditions.Add Type:=xlExpression, Formula1:=CF1
.FormatConditions(1).Interior.Color = 49407
.FormatConditions(1).StopIfTrue = True
.FormatConditions.Add Type:=xlExpression, Formula1:=Replace(CF2, "#", sMiddle)
.FormatConditions(2).Interior.Color = vbRed
.FormatConditions(2).StopIfTrue = True
.FormatConditions.Add Type:=xlExpression, Formula1:=Replace(CF3, "#", sMiddle)
.FormatConditions(3).Interior.Color = 15773696
End With
Application.ScreenUpdating = True
End Sub
