Private Sub CommandButton1_Click()
Dim i&, Mn&, Mx&, C, TabDat, D As Object, R As Range
Set D = CreateObject("Scripting.Dictionary")
TabDat = Range(Cells(4, 1), Cells(Rows.Count, 1).End(3)(1, 2))
For i = LBound(TabDat, 1) To UBound(TabDat, 1)
TabDat(i, 1) = CLng(TabDat(i, 1))
Next i
With Application
Mn = .Min(.Index(TabDat, , 1))
Mx = .Max(.Index(TabDat, , 1))
End With
For i = Mn To Mx: D(i) = "": Next i
For i = LBound(TabDat, 1) To UBound(TabDat, 1)
D(TabDat(i, 1)) = CLng(TabDat(i, 2))
Next i
Application.ScreenUpdating = False
With Cells(4, 5).Resize(D.Count, 1)
.Value = Application.Transpose(D.Keys)
.NumberFormat = "m/d/yyyy"
With .Offset(, 1)
.Value = Application.Transpose(D.Items)
For Each R In .SpecialCells(4).Areas
Mn = R.Offset(-1, 0)(1, 1)
Mx = R.Offset(R.Rows.Count, 0)(1, 1)
R.Value = CDbl((Mn + Mx) / 2)
R.Font.ColorIndex = 3 'Fioriture
Next R
End With
End With
Application.ScreenUpdating = True
End Sub