I have information/data like this:
Can I ask for help in creating a macro that will group dates for a given employee from several lines to one, if the dates are consecutive?
I tried help with Ai, but I failed because I still have problems with formatting dates and writing them correctly, and I cannot change it because it is the result of another action earlier.
- the macro would run in the active sheet,
- applies only to columns A-D
- the result would be transferred to the P-S columns, which need to be cleared first
- my data has no headers
- rows with single dates remain as they are
- ms office 2016 for small office
What I woud like to get after run macro is:
Thank you
8
Please, try the next code. It uses a dictionary and some arrays. Working mostly in memory and dropping only the processed array result, it should be very fast even for large ranges. It assumes that for the same user all data in columns A, B and C columns are the same:
Sub GrupingByUser()
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:
ws.Range("P1").Resize(UBound(arrFin), UBound(arrFin, 2)).Value = arrFin
MsgBox "Ready..."
End Sub
Function MakeDateFromStr(d As String) As Date
MakeDateFromStr = CDate(left(d, 2) & "/" & Mid(d, 4, 2) & "/" & Right(d, 4))
End Function
I tried commenting every code line, so it should be easy understood, I think. If something not clear enough, do not hesitate to ask for clarifications.
CStr(arr(i, 1))
has been used to overpass potential errors in the first column (#N/A
). Even if they are written as string, VBA still understands them as error (for instance, #N/A is understood as Error 2024). It is easy to be written as #N/A, but I do not think to be necessary…
Please, send some feedback after testing it.
14