Consulting

Results 1 to 15 of 15

Thread: Extracting Dates

  1. #1
    VBAX Contributor
    Joined
    Oct 2013
    Posts
    145
    Location

    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


    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

  2. #2
    VBAX Tutor
    Joined
    Mar 2014
    Posts
    210
    Location
    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

  3. #3
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,359
    Please post a sample workbook.

  4. #4
    VBAX Contributor
    Joined
    Oct 2013
    Posts
    145
    Location
    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.

  5. #5
    Knowledge Base Approver VBAX Guru
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    4,008
    Guessing your arrangement, try this replacing your existing macro:
    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 - - - - -This is my signature, it appears after all my posts. Below is not directed at anyone in particular - so don't take offence! - (You might guess why it's there though)
    If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  6. #6
    VBAX Contributor
    Joined
    Oct 2013
    Posts
    145
    Location
    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.

    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


  7. #7
    Knowledge Base Approver VBAX Guru
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    4,008
    Yes, these three lines:
    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.
    p45cal - - - - -This is my signature, it appears after all my posts. Below is not directed at anyone in particular - so don't take offence! - (You might guess why it's there though)
    If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  8. #8
    VBAX Contributor
    Joined
    Oct 2013
    Posts
    145
    Location
    I am trying to upload a sample file and I keep getting this error:

    Upload error.png

    Any ideas?

  9. #9
    Knowledge Base Approver VBAX Guru
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    4,008
    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).
    p45cal - - - - -This is my signature, it appears after all my posts. Below is not directed at anyone in particular - so don't take offence! - (You might guess why it's there though)
    If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  10. #10
    VBAX Contributor
    Joined
    Oct 2013
    Posts
    145
    Location

    Extracting Dates


  11. #11
    Knowledge Base Approver VBAX Guru
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    4,008
    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:
    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 - - - - -This is my signature, it appears after all my posts. Below is not directed at anyone in particular - so don't take offence! - (You might guess why it's there though)
    If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  12. #12
    VBAX Contributor
    Joined
    Oct 2013
    Posts
    145
    Location

    Extracting Dates

    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

  13. #13
    VBAX Contributor
    Joined
    Oct 2013
    Posts
    145
    Location
    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

  14. #14
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,359
    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

  15. #15
    VBAX Contributor
    Joined
    Oct 2013
    Posts
    145
    Location
    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.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •