Extracting Dates

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

Code:

---

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

---

Code:

---

Public Sub CollectDates()
Dim shtSrc As Worksheet, shtTarg As Worksheet
Dim vName, vStart, vEnd
Dim cell As Range


Range("A2").Select
Set shtSrc = ActiveSheet
Sheets.Add
Set shtTarg = ActiveSheet
shtSrc.Activate


While ActiveCell.Value <> ""
  vName = ActiveCell.Value
  Set cell = ActiveCell
  ActiveCell.Offset(0, 1).Select
  vStart = ActiveCell.Value
  While ActiveCell.Value <> ""
      ActiveCell.Offset(0, 1).Select  'next col
  Wend
  vEnd = ActiveCell.Offset(0, -1).Value
 
  shtTarg.Activate
    ActiveCell.Offset(0, 0).Value = vName
    ActiveCell.Offset(0, 1).Value = vStart & " to " & vEnd
    ActiveCell.Offset(1, 0).Select  'next row
  shtSrc.Activate
 
 
  cell.Select  'original spot
  ActiveCell.Offset(1, 0).Select  'next row
Wend


Set cell = Nothing
Set shtSrc = Nothing
Set shtTarg = Nothing
End Sub

---

Please post a sample workbook.

snb,

Due to our company policy and the privacy data contained within, I will not be able to post a sample of the full workbook but I will work on purging the privacy data and post it soon.

RANMAN256,

Does the code you sent replace the code I sent or do I integrate it into the old code?

Thank you both for your quick replies.

Guessing your arrangement, try this replacing your existing macro:

Code:

---

Sub blah()
Dim Wks, zzz, maxresults, rngDates, DestRow, cll, myData, mydatavals, Count, StartBlock, i
Set Wks = Worksheets("Sheet1")
'dim myResults to a big enough size:
Set zzz = Wks.Range("B1").CurrentRegion
maxresults = Application.CountA(zzz) - zzz.Rows.Count
ReDim myresults(1 To maxresults, 1 To 2)

Worksheets("Sheet4").Range("A:B").ClearContents
Set rngDates = Wks.Range(Wks.Range("B1"), Wks.Cells(Rows.Count, "B").End(xlUp)).Offset(, -1)
DestRow = 1
For Each cll In rngDates.Cells
  Set myData = Wks.Range(cll, Wks.Cells(cll.Row, Columns.Count).End(xlToLeft))
  mydatavals = myData.Value
  If IsArray(mydatavals) Then
    Count = 1: StartBlock = 2
    For i = 2 To UBound(mydatavals, 2) - 1
      If mydatavals(1, i + 1) - mydatavals(1, i) <= 1 And Year(mydatavals(1, i)) = Year(mydatavals(1, i + 1)) And Month(mydatavals(1, i)) = Month(mydatavals(1, i + 1)) Then
        Count = Count + 1
      Else
        myresults(DestRow, 1) = mydatavals(1, 1)
        If Count > 1 Then
          myresults(DestRow, 2) = mydatavals(1, StartBlock) & " to " & mydatavals(1, StartBlock + Count - 1)
        Else
          myresults(DestRow, 2) = mydatavals(1, StartBlock)
        End If
        DestRow = DestRow + 1
        StartBlock = StartBlock + Count: Count = 1
      End If
    Next i
    myresults(DestRow, 1) = mydatavals(1, 1)
    If Count > 1 Then
      myresults(DestRow, 2) = mydatavals(1, StartBlock) & " to " & mydatavals(1, StartBlock + Count - 1)
    Else
      myresults(DestRow, 2) = mydatavals(1, StartBlock)
    End If
    DestRow = DestRow + 1
  End If
Next cll
Sheets("Sheet4").Range("A1").Resize(DestRow, 2).Value = myresults
End Sub

---

P45Cal,

Thank you for your reply. I replace my current code with the code you provided and the line of code "ReDim myresults(1 To maxresults, 1 To 2)" causes an error type 9 "Out or Memory". If I RIM it out the code runs until it gets to the end of the dates for the first person and then I get an error type 13 "Script Out of Range"

Again, thank you for your help.

Code:

---

Sub blah()    Dim Wks, zzz, maxresults, rngDates, DestRow, cll, myData, mydatavals, Count, StartBlock, i, myresults
    Set Wks = Worksheets("Sheet1")
    'dim myResults to a big enough size:
    Set zzz = Wks.Range("B1").CurrentRegion
    maxresults = Application.CountA(zzz) - zzz.Rows.Count
    'ReDim myresults(1 To maxresults, 1 To 2)
   
    Worksheets("Sheet4").Range("A:B").ClearContents
    Set rngDates = Wks.Range(Wks.Range("B1"), Wks.Cells(Rows.Count, "B").End(xlUp)).Offset(, -1)
    DestRow = 1
    For Each cll In rngDates.Cells
        Set myData = Wks.Range(cll, Wks.Cells(cll.Row, Columns.Count).End(xlToLeft))
        mydatavals = myData.Value
        If IsArray(mydatavals) Then
            Count = 1: StartBlock = 2
            For i = 2 To UBound(mydatavals, 2) - 1
                If mydatavals(1, i + 1) - mydatavals(1, i) <= 1 And Year(mydatavals(1, i)) = Year(mydatavals(1, i + 1)) And Month(mydatavals(1, i)) = Month(mydatavals(1, i + 1)) Then
                    Count = Count + 1
                Else
                    myresults(DestRow, 1) = mydatavals(1, 1)
                    If Count > 1 Then
                        myresults(DestRow, 2) = mydatavals(1, StartBlock) & " to " & mydatavals(1, StartBlock + Count - 1)
                    Else
                        myresults(DestRow, 2) = mydatavals(1, StartBlock)
                    End If
                    DestRow = DestRow + 1
                    StartBlock = StartBlock + Count: Count = 1
                End If
            Next i
            myresults(DestRow, 1) = mydatavals(1, 1)
            If Count > 1 Then
                myresults(DestRow, 2) = mydatavals(1, StartBlock) & " to " & mydatavals(1, StartBlock + Count - 1)
            Else
                myresults(DestRow, 2) = mydatavals(1, StartBlock)
            End If
            DestRow = DestRow + 1
        End If
    Next cll
    Sheets("Sheet4").Range("A1").Resize(DestRow, 2).Value = myresults
End Sub

---

Yes, these three lines:

Code:

---

Set zzz = Wks.Range("B1").CurrentRegion
maxresults = Application.CountA(zzz) - zzz.Rows.Count
ReDim myresults(1 To maxresults, 1 To 2)

---

were a bit of a gamble on my part, to try and guess how big the results might be (I'm trying to avoid ReDim Preserve and later transposition as the former is more resource hungry and the latter has limits). I didn't expect Out of memory though.
Do me a favour and tell me what ends up being selected (how big a range, perhaps its address, even an idea of its contents (formulae, numbers, text?), does it more than cover the cells that need to be processed) when you do the following:

• Select the single cell B1 on the relevant sheet
• Press F5 on the keyboard
• Click Special…
• Choose Current region
• Click OK

You could try changing:
CountA(zzz)
to:
Count(zzz)

You're beginning to see the problems with not including a sample file.

I am trying to upload a sample file and I keep getting this error:

Attachment 21313

Any ideas?

Is it too big?
It should say so somewhere if that's the case - look carefully.
You could try saving as .xlsb since those files are usually smaller.
Failing that, you could upload to a file sharing site, and provide a link to it here (ensuring you give permissions for anyone to download it).

I finally got the file to upload!


Attachment 21323Attachment 21323Attachment 21323

Your range to process started in row 3 rather than row 1 - so you can see the benefit of uploading a file. A tweak to look at row 3 instead of row 1:

Code:

---

Sub blah()
Dim Wks, zzz, maxresults, rngDates, DestRow, cll, myData, mydatavals, Count, StartBlock, i, myresults
Set Wks = Worksheets("Sheet1")
'dim myResults to a big enough size:
Set zzz = Wks.Range("B3").CurrentRegion
maxresults = Application.Count(zzz) - zzz.Rows.Count
ReDim myresults(1 To maxresults, 1 To 2)

Worksheets("Sheet4").Range("A:B").ClearContents
Set rngDates = Wks.Range(Wks.Range("B3"), Wks.Cells(Rows.Count, "B").End(xlUp)).Offset(, -1)
DestRow = 1
For Each cll In rngDates.Cells
  Set myData = Wks.Range(cll, Wks.Cells(cll.Row, Columns.Count).End(xlToLeft))
  mydatavals = myData.Value
  If IsArray(mydatavals) Then
    Count = 1: StartBlock = 2
    For i = 2 To UBound(mydatavals, 2) - 1
      If mydatavals(1, i + 1) - mydatavals(1, i) <= 1 And Year(mydatavals(1, i)) = Year(mydatavals(1, i + 1)) And Month(mydatavals(1, i)) = Month(mydatavals(1, i + 1)) Then
        Count = Count + 1
      Else
        myresults(DestRow, 1) = mydatavals(1, 1)
        If Count > 1 Then
          myresults(DestRow, 2) = mydatavals(1, StartBlock) & " to " & mydatavals(1, StartBlock + Count - 1)
        Else
          myresults(DestRow, 2) = mydatavals(1, StartBlock)
        End If
        DestRow = DestRow + 1
        StartBlock = StartBlock + Count: Count = 1
      End If
    Next i
    myresults(DestRow, 1) = mydatavals(1, 1)
    If Count > 1 Then
      myresults(DestRow, 2) = mydatavals(1, StartBlock) & " to " & mydatavals(1, StartBlock + Count - 1)
    Else
      myresults(DestRow, 2) = mydatavals(1, StartBlock)
    End If
    DestRow = DestRow + 1
  End If
Next cll
Sheets("Sheet4").Range("A1").Resize(DestRow, 2).Value = myresults
End Sub

---

p45Cal,

Thank you for your response, it seem to be working better. Is there a way to place a space in between each person's output on sheet4?

Example:

Bill	1/2/2018 to 1/2/2018
SPACE	SPACE
Jill	1/3/2018 to 1/10/2018

p45Cal,

I figured out the spacing part and the code is working good. I want to thank you for your hard work and diligence on my question.

Again, thank you

Code:

---

Sub M_snb()
    sn = Sheet1.Cells(3, 1).CurrentRegion
    sp = Sheet2.Cells(3, 1).CurrentRegion
    sq = Sheet4.Cells(3, 1).CurrentRegion
   
    For T = 1 To 3
      st = Choose(T, sn, sp, sq)
      For j = 1 To UBound(st)
            For jj = 2 To UBound(st, 2)
              If st(j, jj) <> "" Then y = jj
            Next
            st(j, 2) = st(j, 2) & " to " & st(j, y)
      Next
      Sheet3.Cells(Rows.Count, 6).End(xlUp).Offset(1).Resize(UBound(st), 2) = st
    Next
End Sub

---

snb,
Thank you for your response however, it returns dates based on a year (1/1/2018 to 12/31/2018) as opposed to based on a month (1/1/2018 to 1/20/2018, 2/10/2018 to 2/27/2018) and it will not complete the extraction I receive a type mismatch error.

p45cal,
Your code does exactly what I need it to do and (so far) it does not care whether there is a single date in a month or only one date in a year it returns the correct format response.

Thank you so much for your efforts on helping me with this project.