Arrive Date Ranges 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