Arrive Date Ranges VBA - vba

Question

First of all i'm just a beginner in VBA and I'm Stuck in the middle and couldn't find a possible way out. To be precise on my requirement, Attached below is the Snapshot of the data which i have currently. In the Date Range column i would need a date range based on the Dates available in each invoices. If a continuity breaks in the dates i would need the dates separated by comma which is shown in the sample data. Below is my piece of code which arrives only the dates and couldn't form a date range. Hope i can find my way out and would be earning something new out of this :-) Thanks!]1
Sub DD()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableCancelKey = False
.EnableEvents = False
End With
Sheets("Claim Lines").Select
ActiveWorkbook.Worksheets("Claim Lines").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Claim Lines").Sort.SortFields.Add Key:=Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
ActiveWorkbook.Worksheets("Claim Lines").Sort.SortFields.Add Key:=Range("D1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Claim Lines").Sort
.SetRange ActiveSheet.UsedRange
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("B2").Select
Do
If ActiveCell.Value = ActiveCell.Offset(1, 0).Value Then
StrtRow = 2
tmperow = ActiveSheet.UsedRange.Rows.Count
For j = 0 To Application.WorksheetFunction.CountIf(Range("B" & StrtRow & ":B" & tmperow), ActiveCell.Value) - 1
If j = 0 Then
DOS = CDate(Cells(ActiveCell.Offset(0, 2).Row + j, "D").Value)
ElseIf j = Application.WorksheetFunction.CountIf(Range("B" & StrtRow & ":B" & tmperow), ActiveCell.Value) - 1 Then
ElseIf DOS = DOS Then
DOS = CDate(Cells(ActiveCell.Offset(0, 2).Row + j, "D").Value)
ElseIf j = Application.WorksheetFunction.CountIf(Range("B" & StrtRow & ":B" & tmperow), ActiveCell.Value) - 1 Then
ElseIf DOS = DOS Then
DOS = DOS & " & " & CDate(Cells(ActiveCell.Offset(0, 2).Row + j, "D").Value)
Else
DOS = DOS & ", " & CDate(Cells(ActiveCell.Row + j, "D").Value)
End If
Next
Range("N" & ActiveCell.Row).Value = DOS & " to " & DOS
DOS = ""
Else
Range("N" & ActiveCell.Row).Value = Range("D" & ActiveCell.Row).Value
End If
ActiveCell.Offset(1, 0).Select
Loop Until IsEmpty(ActiveCell.Value)
End Sub

Answer 1

I quickly wrote this. I am sure there can be better ways to achieve this but I could only spend this much time before I hit the sack :)
Sub Sample()
Dim ws As Worksheet
Dim dString As String, ss As String
Dim lRow As Long, i As Long
Dim sRow As Long, eRow As Long
Dim sDate As Date, eDate As Date
'~~> This is your worksheet which has data
Set ws = ThisWorkbook.Worksheets("Claim Lines")
'~~> Setting start row and end row for Col C
sRow = 2: eRow = 2
With ws
'~~> Sort Col A and B on Col A first and then on Col B
.Columns("A:B").Sort Key1:=.Range("A1"), Key2:=.Range("B1"), _
Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'~~> Find Last Row of Col A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Set the Initial Start Date and End Date
sDate = .Range("B2").Value: eDate = .Range("B2").Value
'~~> Loop through the data
For i = 2 To lRow
'~~> Check if the value of the current cell in Col A
'~~> is the same as the value in the next cell
If .Range("A" & i) = .Range("A" & i + 1) Then
'~~> Compare date values in Col B to check if they are in sequence
If .Range("B" & i + 1) - .Range("B" & i) = 1 Then
'~~> If yes then set it as new End Date
eDate = .Range("B" & i + 1)
Else
'~~> Get the string to be written in Col C
dString = GetDString(dString, sDate, eDate, .Range("B" & i))
'~~> Set New Start Date
sDate = .Range("B" & i + 1)
End If
Else
eRow = i
dString = GetDString(dString, sDate, eDate, .Range("B" & i))
.Range("C" & sRow & ":C" & eRow).Value = dString
dString = "": sRow = eRow + 1
sDate = .Range("B" & i + 1).Value
eDate = .Range("B" & i + 1).Value
End If
Next i
End With
End Sub
'~~> Function to get the string to be written in Col C
Private Function GetDString(s As String, StartDate As Date, _
endDate As Date, CurCell As Range) As String
If s = "" Then
If endDate = CurCell.Value Then
If StartDate = endDate Then
s = StartDate
Else
s = StartDate & "-" & endDate
End If
Else
s = (StartDate & "-" & endDate) & "," & CurCell.Value
End If
Else
If endDate = CurCell.Value Then
s = s & "," & StartDate & "-" & endDate
Else
s = s & "," & CurCell.Value
End If
End If
GetDString = s
End Function
ScreenShot of various tests