The code below is used to arrange names and dates from row form (up to 50 rows) to column form. The code works OK except when there is only one date in a month or one date per person and then it errors with “Script out of range”. What I need help with is when there is only one date per month or one date per person; the code would just assign the date as the start date and end date as the same, see example below.
Hope this makes sense and thank you any and all help.


Source Data:
Jane Doe 1/1/2018 1/2/2018 1/3/2018 2/1/2018 2/2/2018
Rodger Smith 2/19/2018


Desired Output:
Jane Doe 1/1/2018 to 1/3/2018
Jane Doe 2/1/2018 to 2/2/2018
Rodger Smith 2/19/2018 to 2/19/2018 


Sub SplitDates()

Worksheets("Sheet1").Activate
Call SortDataRowByRow
    Dim Cell As Range
    Dim Data As Variant
    Dim i As Long
    Dim nbrDates As Variant
    Dim r As Long
    Dim rngDates As Range
    Dim rngOutput As Range
    Dim StartDate As Date
    Dim Wks As Worksheet
        
        ReDim Data(1 To 2, 1 To 1)
        
        Set rngOutput = Worksheets("Sheet4").Range("A1")
        rngOutput.Range("A:B").ClearContents
        
        Set Wks = Worksheets("Sheet1")
        
        Set rngDates = Wks.Range("B1")
        Set rngDates = Wks.Range(rngDates, Wks.Cells(Rows.Count, "B").End(xlUp))
        
        For Each Cell In rngDates
        
            If Not IsEmpty(Cell) Then
                Set rngDates = Wks.Range(Cell, Wks.Cells(Cell.Row, Columns.Count).End(xlToLeft))
                nbrDates = rngDates.Value
                
                If TypeName(nbrDates) = "Variant()" Then
                    StartDate = CDate(nbrDates(1, 1))
            
                    For i = 1 To UBound(nbrDates, 2) - 1
                        If nbrDates(1, i + 1) - nbrDates(1, i) <> 1 Then
                            r = r + 1
                            ReDim Preserve Data(1 To 2, 1 To r)
                            
                            Data(1, r) = Cell.Offset(0, -1)
                            Data(2, r) = StartDate & "  to  " & CDate(nbrDates(1, i))
                            
                            StartDate = CDate(nbrDates(1, i + 1))
                            i = i + 1
                        End If
                    Next i
            
                    r = r + 2
                    ReDim Preserve Data(1 To 2, 1 To r)
                    
                    Data(1, r - 1) = Cell.Offset(0, -1)
                    Data(2, r - 1) = StartDate & "  to  " & CDate(nbrDates(1, i))
                End If
                
            End If
           
        Next Cell
        
        Data = Application.Transpose(Data)
        
        rngOutput.Resize(UBound(Data), 2).Value = Data
Worksheets("Worksheets").Activate
Call SplitDates1
End Sub