Consulting

Results 1 to 15 of 15

Thread: Extracting Dates

  1. #1

    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 
    
    
    Formatting tags added by mark007

  2. #2
    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 
    
    
    Formatting tags added by mark007

  3. #3
    Please post a sample workbook.

  4. #4
    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
    3,883
    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 
    
    
    Formatting tags added by mark007
    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
    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 
     
     
    [COLOR=#333333][/COLOR] 
    
    
    Formatting tags added by mark007


  7. #7
    Knowledge Base Approver VBAX Guru
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    3,883
    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) 
    
    
    Formatting tags added by mark007
    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
    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
    3,883
    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

  11. #11
    Knowledge Base Approver VBAX Guru
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    3,883
    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 
    
    
    Formatting tags added by mark007
    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

    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
    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
    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 
    
    
    Formatting tags added by mark007

  15. #15
    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
  •