This is a continuation of the thread that can be found here: previous question
I slightly edited the macro for myself in the final stage, so I'm pasting the current code here:
Sub GrupingByUser_pop()
Dim ws As Worksheet, lastR As Long, arr, arrIt, arrFin, firstDate As Date, lastDate As Date
Dim i As Long, j As Long, dict As Object
Set ws = ActiveSheet
lastR = ws.Range("D" & ws.Rows.Count).End(xlUp).Row 'last row on D:D
arr = ws.Range("A1:D" & lastR).Value 'place the range in an array for faster iteration
Set dict = CreateObject("scripting.Dictionary") 'set the necessary dictionary
For i = 1 To UBound(arr)
'if the first columns concatenation does not exist as a key, add it to dictionary:
If Not dict.Exists(CStr(arr(i, 1)) & "|" & arr(i, 2) & "|" & arr(i, 3)) Then
dict.Add CStr(arr(i, 1)) & "|" & arr(i, 2) & "|" & arr(i, 3), Array(arr(i, 4)) 'the item placed in an array
Else
arrIt = dict(CStr(arr(i, 1)) & "|" & arr(i, 2) & "|" & arr(i, 3)) 'extract the existing item in an array
ReDim Preserve arrIt(UBound(arrIt) + 1) 'redim the item array preserving existing
arrIt(UBound(arrIt)) = arr(i, 4) 'place the date as the last array element
dict(CStr(arr(i, 1)) & "|" & arr(i, 2) & "|" & arr(i, 3)) = arrIt 'place the array back as the dict item
End If
Next i
'redim the final array:
ReDim arrFin(1 To dict.Count, 1 To 4)
'process the dictionary data and place them in the final array:
For i = 0 To dict.Count - 1
arrIt = Split(dict.keys()(i), "|") 'split the key by "|" separator
For j = 0 To UBound(arrIt): arrFin(i + 1, j + 1) = arrIt(j): Next j 'place each element in its column
firstDate = MakeDateFromStr(CStr(dict.Items()(i)(0))) 'extract first date
arrIt = dict.Items()(i)
lastDate = MakeDateFromStr(CStr(arrIt(UBound(arrIt)))) 'last date
If Month(firstDate) = Month(lastDate) Then 'if both date are inside the same month:
If lastDate = firstDate Then 'if only one date:
arrFin(i + 1, 4) = firstDate
Else 'if more dates (in the same month)
arrFin(i + 1, 4) = Format(Day(firstDate), "00") & " - " & Format(lastDate, "dd.mm.yyyy")
End If
Else 'if not in the same month:
arrFin(i + 1, 4) = Format(firstDate, "dd.mm.yyyy") & " - " & Format(lastDate, "dd.mm.yyyy")
End If
Next i
'drop the processed array result, at once:
Range("P1:T600").ClearContents
ws.Range("P1").Resize(UBound(arrFin), UBound(arrFin, 2)).Value = arrFin
'sort the range P1:T600 alphabetically by column P
With ws.Sort
.SortFields.Clear
.SortFields.Add Key:=ws.Range("P1:P600"), Order:=xlAscending
.SetRange ws.Range("P1:T600")
.Header = xlNo
.Apply
End With
End Sub
Function MakeDateFromStr(d As String) As Date
MakeDateFromStr = CDate(Mid(d, 4, 2) & "/" & Left(d, 2) & "/" & Right(d, 4))
End Function
This is a macro that, based on data in several columns, groups dates for a specific person and saves them in the form from - to.
Currently, however, the macro does not take into account that there may be a gap in the given set of dates.
The expected result would be as follows:
The dates in column [D] are simple text and as a result of the macro operation they have the following format: dd/mm/yyyy or dd-dd/mm/yyyy for groups in the same month (day / month / year - EU) - see example below
Example and expected result in excel for the same month:
Data:
Result:
I left the date justification in the results column as it was originally formatted because it helps me visually separate groups from individual days.
Please, try the next adapted code. It uses a separate function able to interpret the date intervals:
Sub GrupingByUser()
Dim ws As Worksheet, lastR As Long, arr, arrIt, arrFin
Dim i As Long, j As Long, dict As Object
Set ws = ActiveSheet
lastR = ws.Range("D" & ws.rows.count).End(xlUp).row 'last row on D:D
arr = ws.Range("A1:D" & lastR).Value 'place the range in an array for faster iteration
Set dict = CreateObject("scripting.Dictionary") 'set the necessary dictionary
For i = 1 To UBound(arr)
If CStr(arr(i, 1)) & arr(i, 2) & arr(i, 3) <> "" Then 'if not an empty row:
'if the first columns concatenation does not exist as a key, add it to dictionary:
If Not dict.Exists(CStr(arr(i, 1)) & "|" & arr(i, 2) & "|" & arr(i, 3)) Then
dict.Add CStr(arr(i, 1)) & "|" & arr(i, 2) & "|" & arr(i, 3), Array(arr(i, 4)) 'the item placed in an array
Else
arrIt = dict(CStr(arr(i, 1)) & "|" & arr(i, 2) & "|" & arr(i, 3)) 'extract the existing item in an array
ReDim Preserve arrIt(UBound(arrIt) + 1) 'redim the item array preserving existing
arrIt(UBound(arrIt)) = arr(i, 4) 'place the date as the last array element
dict(CStr(arr(i, 1)) & "|" & arr(i, 2) & "|" & arr(i, 3)) = arrIt 'place the array back as the dict item
End If
End If
Next i
'redim the final array:
ReDim arrFin(1 To dict.count, 1 To 4)
'process the dictionary data and place them in the final array:
For i = 0 To dict.count - 1
arrIt = Split(dict.keys()(i), "|") 'split the key by "|" separator
For j = 0 To UBound(arrIt): arrFin(i + 1, j + 1) = arrIt(j): Next j 'place each element in its column
arrFin(i + 1, 4) = DateIntervalsSplitMonths(dict.Items()(i)) 'place the calculated interval(s)
Next i
'drop the processed array result, at once and format a little the range:
Dim rngRet As Range: Set rngRet = ws.Range("P1").Resize(UBound(arrFin), UBound(arrFin, 2))
With rngRet
.Value = arrFin
.EntireColumn.AutoFit
.EntireRow.AutoFit
.VerticalAlignment = xlCenter
End With
PlaceBorders rngRet
MsgBox "Ready..."
End Sub
Function MakeDateFromStr(d As String) As Date
'MakeDateFromStr = CDate(left(d, 2) & "/" & Mid(d, 4, 2) & "/" & Right(d, 4)) 'uncomment for "dd/mm/yyyy"
MakeDateFromStr = CDate(Mid(d, 4, 2) & "/" & left(d, 2) & "/" & Right(d, 4)) 'for localized format "mm/dd/yyyy"
End Function
Function DateIntervalsSplitMonths(arrD) As String 'it calculates the time interval(s)
Dim frstD As Date, lstD As Date, i As Long
Dim prevD As Date, follD As Date, strRet As String
frstD = MakeDateFromStr(CStr(arrD(0))) 'extract first date
lstD = MakeDateFromStr(CStr(arrD(UBound(arrD)))) 'last date
If lstD = frstD Then
DateIntervalsSplitMonths = frstD 'for one single Date record
Else 'for more than a single data:
For i = 1 To UBound(arrD) 'iterate between
prevD = MakeDateFromStr(CStr(arrD(i))) 'previous Date
follD = MakeDateFromStr(CStr(arrD(i - 1))) 'following Date
'if dates are not consecutive OR previous date monts <> followind date monts OR reaches the last array element:
If prevD <> follD + 1 Or Month(prevD) <> Month(follD) Or i = UBound(arrD) Then
lstD = IIf(i = UBound(arrD), prevD, follD) 'extract last date in case of last array element or something else
If Month(frstD) = Month(lstD) Then 'if first date month is the same with last date month
strRet = strRet & Format(Day(frstD), "00") & " - " & Format(lstD, "dd/mm/yyyy") & vbLf
Else
strRet = strRet & Format(frstD, "dd/mm/yyyy") & " - " & Format(lstD, "dd/mm/yyyy") & vbLf
End If
frstD = prevD 'reinitialize first date as the prvious one
End If
Next i
DateIntervalsSplitMonths = left(strRet, Len(strRet) - 1) 'return strRed - dates interval defined above
End If
End Function
Sub PlaceBorders(rng As Range) 'new sub able to place borders...
Dim arrBord, el
arrBord = Application.Evaluate("Row(7:12)")
For Each el In arrBord
With rng.Borders(el)
.LineStyle = xlContinuous: .Weight = xlThin: .ColorIndex = 0
End With
Next el
End Sub
The function is also able to interpret dates from two different months, it returns each interval on the cell different line and also splits continuous dates intervals per months...
Please, send some feedback after testing it.