PDA

View Full Version : [SOLVED] Extracting Dates



oam
01-03-2018, 08:54 PM
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

ranman256
01-04-2018, 07:40 AM
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

snb
01-04-2018, 08:51 AM
Please post a sample workbook.

oam
01-04-2018, 03:08 PM
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.

p45cal
01-04-2018, 05:55 PM
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

oam
01-05-2018, 03:35 PM
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

p45cal
01-06-2018, 04:09 AM
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.

oam
01-07-2018, 08:37 AM
I am trying to upload a sample file and I keep getting this error:

21313

Any ideas?

p45cal
01-07-2018, 10:56 AM
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).

oam
01-08-2018, 11:27 PM
I finally got the file to upload!


213232132321323

p45cal
01-12-2018, 11:34 AM
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

oam
01-17-2018, 06:16 PM
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

oam
01-17-2018, 08:02 PM
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

snb
01-18-2018, 01:49 AM
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

oam
01-19-2018, 05:22 PM
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.