Sub tgr()
Dim rngA As Range, rngFound As Range
Dim arrUnq As Variant, arrResults As Variant
Dim arrIndex As Long, ResultIndex As Long
Dim NumDays As Long, FirstDay As Long, DayIndex As Long
Dim strFirst As String
Set rngA = ActiveSheet.Range("A1", Cells(Rows.Count, "A"))
rngA.AdvancedFilter xlFilterCopy, , Cells(1, Columns.Count), True
arrUnq = Range(Cells(2, Columns.Count), Cells(Rows.Count, Columns.Count).End(xlUp)).Value
Columns(Columns.Count).Delete
With rngA.Offset(, 1)
Cells(Rows.Count, Columns.Count).Copy
.PasteSpecial xlPasteAll, xlPasteSpecialOperationAdd
.NumberFormat = "m/d/yyyy h:mm:ss AM/PM"
NumDays = Evaluate("Int(Max(" & .Address & "))-Int(Min(" & .Address & "))+1")
FirstDay = Evaluate("Int(Min(" & .Address & "))")
End With
ReDim arrResults(1 To UBound(arrUnq, 1) * NumDays, 1 To 4)
For arrIndex = 1 To UBound(arrResults, 1) Step NumDays
For DayIndex = 1 To NumDays
ResultIndex = ResultIndex + 1
arrResults(ResultIndex, 1) = arrUnq(Int((ResultIndex - 1) / NumDays) + 1, 1)
arrResults(ResultIndex, 2) = FirstDay + DayIndex - 1
Next DayIndex
Set rngFound = rngA.Find(arrResults(ResultIndex, 1), , , xlWhole)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Do While Not rngFound Is Nothing
With rngFound
DayIndex = Int(.Offset(, 1).Value2) - FirstDay + 1 + ResultIndex - NumDays
'C/In
If .Offset(, 2).Value = "C/In" Then
If .Offset(, 1).Value2 < arrResults(DayIndex, 3) Or arrResults(DayIndex, 3) = 0 Then
arrResults(DayIndex, 3) = .Offset(, 1).Value2
End If
End If
'C/Out
If .Offset(, 2).Value = "C/Out" Then
If .Offset(, 1).Value2 > arrResults(DayIndex, 4) Or arrResults(DayIndex, 4) = 0 Then
arrResults(DayIndex, 4) = .Offset(, 1).Value2
End If
End If
End With
Set rngFound = rngA.Find(arrResults(ResultIndex, 1), rngFound, , xlWhole)
If rngFound.Address = strFirst Then Exit Do
Loop
Set rngFound = Nothing
strFirst = vbNullString
End If
For DayIndex = 1 To NumDays
If arrResults(DayIndex + ResultIndex - NumDays, 3) = 0 Then arrResults(DayIndex + ResultIndex - NumDays, 3) = "No C/In Found"
If arrResults(DayIndex + ResultIndex - NumDays, 4) = 0 Then arrResults(DayIndex + ResultIndex - NumDays, 4) = "No C/Out Found"
Next DayIndex
Next arrIndex
If ResultIndex > 0 Then
Range("E2:H" & Cells(Rows.Count, "E").End(xlUp).Row).ClearContents
With Range("E2:H2").Resize(ResultIndex)
.Value = arrResults
.Offset(, 1).Resize(, 1).NumberFormat = "m/d/yyyy"
.Offset(, 2).Resize(, 2).NumberFormat = "h:mm:ss AM/PM"
End With
End If
End Sub
Bookmarks