```
[/COLOR]Sub test()Dim Dws As Worksheet
Dim SPws As Worksheet, a
Dim i As Long, d As Long, j As Long, LastR As Long, LastRR As Long, cnt As Long
Dim hr
Application.ScreenUpdating = False
Set Dws = Worksheets("Data")
Set SPws = Worksheets("Spreadsheet")
If Dws.AutoFilterMode = True Then
Dws.Range("A1").AutoFilter
End If
'Number of last day
d = Day(DateSerial(Year(Dws.Range("A2")), Month(Dws.Range("A2")) + 1, 0))
LastRR = Dws.Cells(Rows.Count, 1).End(xlUp).Row
With SPws
'Making heading of spreadsheet
.Range("A1").Value = "Date"
.Range("B1").Value = "Check-in"
.Range("C1").Value = "Count"
.Range("D1").Value = "Check-out"
.Range("E1").Value = "Count"
'Making columnA of Spreadsheet
j = 2
For i = 1 To d
.Range(.Cells(j, 1), .Cells(j + 23, 1)) = DateSerial(Year(Dws.Range("A2")), Month(Dws.Range("A2")), i)
j = j + 24
Next
LastR = .Cells(.Rows.Count, 1).End(xlUp).Row
'Making columnB and columnC of preadsheet
For j = 1 To LastR - 24 Step 24
For i = 0 To 23
.Cells(i + j + 1, 2).Value = i & ":00"
Next
Next
.Range(.Range("D2"), .Cells(LastR, 4)).Value = .Range(.Range("B2"), .Cells(LastR, 2)).Value
'For average
.Range(.Range("G2"), .Cells(d, 7)).Value = [B].Range(.Range("B2"), .Cells(d, 2)).Value[/B]
.Columns(2).NumberFormatLocal = "h:mm AM/PM"
.Columns(4).NumberFormatLocal = "h:mm AM/PM"
.Columns(7).NumberFormatLocal = "h:mm AM/PM"
End With
'Counting each day of each hour
With Dws
'Check-in
j = 2
For i = 2 To LastR Step 24
For hr = 1 To 24
Dws.Range("A1").AutoFilter Field:=1, Criteria1:=Format(SPws.Cells(i, 1), "m/d/yyyy")
Dws.Range("A1").AutoFilter Field:=2, Criteria1:=">=" & hr - 1 & ":00", Operator:=xlAnd, Criteria2:=" <=" & hr - 1 & ":59"
cnt = WorksheetFunction.Subtotal(3, .Columns(1)) - 1
SPws.Cells(j, 3).Value = cnt
j = j + 1
.ShowAllData
Next
Next
'Check-out
j = 2
For i = 2 To LastR Step 24
For hr = 1 To 24
Dws.Range("A1").AutoFilter Field:=1, Criteria1:=Format(SPws.Cells(i, 1), "m/d/yyyy")
Dws.Range("A1").AutoFilter Field:=3, Criteria1:=">=" & hr - 1 & ":00", Operator:=xlAnd, Criteria2:=" <=" & hr - 1 & ":59"
cnt = WorksheetFunction.Subtotal(3, .Columns(1)) - 1
SPws.Cells(j, 5).Value = cnt
j = j + 1
.ShowAllData
Next
Next
End With
SPws.Range("H2").Value = "=AVERAGEIF(B:B,G2,C:C)"
SPws.Range("H2").Copy [B]SPws.Range(SPws.Range("H3"), SPws.Cells(d, 8))[/B]
Application.ScreenUpdating = True
End Sub[COLOR=#333333]
```