Private Sub Workbook_BeforeClose(Cancel As Boolean)
ActiveSheet.Name = "Sheet1"
Sheets("Sheet1").Range("H" & Rows.Count).End(xlUp).Value = Date
Dim lr As Long
lr = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
Range("A2:A3").AutoFill Destination:=Range("A2:A" & lr)
Dim ws As Worksheet
Dim d As Object, colData As String, colOut As String
Dim x&, zr&, k, e, t!
t = Timer
Set ws = ActiveSheet '
colData = "C" 'Column of data to count
colOut = "D" 'Output column for running count
Set d = CreateObject("scripting.dictionary")
zr = ws.Cells(Rows.Count, colData).End(xlUp).Row
e = ws.Range(ws.Cells(2, colData), ws.Cells(zr, colData))
ReDim k(1 To UBound(e, 1), 1 To 1)
For x = LBound(e, 1) To UBound(e, 1)
If d.exists(e(x, 1)) Then
d(e(x, 1)) = d(e(x, 1)) + 1
k(x, 1) = d(e(x, 1))
Else
d(e(x, 1)) = 1
k(x, 1) = 1
End If
Next x
ws.Range(ws.Cells(2, colOut), ws.Cells(zr, colOut)) = k
'MsgBox Format(Timer - t, "0.00 secs"), , "Process Time"
Cells.Select
Cells.EntireColumn.AutoFit
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("A1").Select
End Sub