Option Explicit
Sub test()
Dim a, i As Long, ii As Long, dic As Object, n As Long, txt As String
Dim EDay As Date, myIn As Date, myOut As Date, myDate As String
With Sheets("available database").Cells(1).CurrentRegion
Set dic = CreateObject("Scripting.Dictionary")
a = Application.Trim(Application.Index(.Value, Evaluate("row(1:" & _
.Rows.Count & ")"), Array(2, 4, 5, 6, 8, 8, 8))): n = 1
End With
For i = 2 To UBound(a, 1)
EDay = a(i, 2): myIn = 0: myOut = 0
If a(i, 3) <> "" Then
myIn = CDate(Split(a(i, 3))(0)) + TimeValue(Split(a(i, 3))(1))
End If
If a(i, 4) <> "" Then
myOut = CDate(Split(a(i, 4))(0)) + TimeValue(Split(a(i, 4))(1))
End If
If Not dic.exists(a(i, 1)) Then
n = n + 1: dic(a(i, 1)) = n
a(n, 1) = a(i, 1): a(n, 2) = myIn: a(n, 3) = myOut: a(n, 4) = EDay: a(n, 5) = EDay
Set a(n, 7) = CreateObject("System.Collections.SortedList")
End If
myDate = EDay - Day(EDay) + 1
If Not a(dic(a(i, 1)), 7).Contains(myDate) Then
Set a(dic(a(i, 1)), 7)(myDate) = CreateObject("System.Collections.ArrayList")
End If
If Not a(dic(a(i, 1)), 7)(myDate).Contains(Day(EDay)) Then a(dic(a(i, 1)), 7)(myDate).Add Day(EDay)
If a(dic(a(i, 1)), 2) > myIn Then a(dic(a(i, 1)), 2) = myIn
If a(dic(a(i, 1)), 3) < myOut Then a(dic(a(i, 1)), 3) = myOut
If a(dic(a(i, 1)), 4) > EDay Then a(dic(a(i, 1)), 4) = EDay
If a(dic(a(i, 1)), 5) < EDay Then a(dic(a(i, 1)), 5) = EDay
Next
For i = 2 To n
a(i, 6) = 0
For ii = 0 To a(i, 7).Count - 1
txt = txt & IIf(txt <> "", " & ", "") & Format$(a(i, 7).GetKey(ii), "mmm yy") & ": "
txt = txt & Join(a(i, 7).GetByIndex(ii).ToArray, ",")
a(i, 6) = a(i, 6) + a(i, 7).GetByIndex(ii).Count
Next
a(i, 7) = txt: txt = ""
Next
With Sheets.Add.Cells(1).Resize(n, UBound(a, 2))
.Value = a
.VerticalAlignment = xlCenter
.Rows(1).Value = Array("PERSONNUM", "In", "Out", "Report date from", "Report date To", _
"No. of Shifts attended" & vbLf & "(in between to & from dates)", "Details")
.Columns("a:b").NumberFormat = "yyyy/m/d h:mm:ss"
.Columns("d:e").NumberFormat = "dd/mmm/yyyy"
.ColumnWidth = 50
.Columns.AutoFit: .Rows.AutoFit
MIOPS
End With
End Sub
Sub MIOPS(): Dim r As Long, wa As Worksheet 'XLAdept Code
Dim w1 As Worksheet, wd As Worksheet, MP As String, PN As String
Set w1 = ActiveSheet: Set wd = Sheets("Desired worksheet")
Set wa = Sheets("Available database"): wd.Cells(1, 8) = "Missed Punches"
With CreateObject("Scripting.Dictionary"): PN = wa.Cells(2, 2)
For r = 2 To wa.Range("A" & Rows.Count).End(xlUp).Row
If wa.Cells(r, 2) <> PN Then MP = "": PN = wa.Cells(r, 2)
If wa.Cells(r, 5).Value = 0 Or wa.Cells(r, 6).Value = 0 Then
If MP = "" Then
MP = IIf(wa.Cells(r, 5).Value = 0, "In ", "Out ") & wa.Cells(r, 4)
Else: MP = MP & " " & _
IIf(wa.Cells(r, 5).Value = 0, "In ", "Out ") & wa.Cells(r, 4)
End If: .Item(PN) = MP: End If
Next r:
For r = 2 To wd.Range("A" & Rows.Count).End(xlUp).Row: PN = wd.Cells(r, 1)
MP = .Item(PN)
If MP <> "" Then _
wd.Cells(r, 8).Interior.ColorIndex = 6: wd.Cells(r, 8).WrapText = True
wd.Cells(r, 8) = .Item(PN): Next r
End With: End Sub
LinkBack URL
About LinkBacks
RavindraK 
Register To Reply
Originally Posted by RavindraK
Bookmarks