Given a list of date ranges...We'll call empTimeOffPeriods
6/2/2016, 6/3/2016, 6/4/2016
6/8/2016, 6/9/2016, 6/10/2016, 6/11/2016
I need to find which consecutive date range a specific date (empRequestedOffDate) falls within
So,
6/4/2016 would fall withing the 6/2/2016-6/4/2016 Range
6/9/2016 would fall withing the 6/8/2016-6/11/2016 Range...etc.
my empTimeOffPeriodsis already sorted.
I'm doing this in VB.net
'Find all approved future events for team employee
empPtoDates = EventsManager.GetEventPaidTimeOffList(empDTO.UserId).FindAll(Function(x) x.EventDate >= DateTime.Today And x.Status = 1)
empOverLappingDates = empPtoDates.**'NOT SURE WHAT TO DO HERE**
'Build "EventType: (PeriodStart-PeriodEnd)"
If empPtoDates.Count > 0 Then
stbEventRanges.Append(empEvent).Append(": ")
stbEventRanges.Append(empOverLappingDates.First.EventDate.ToShortDateString()).Append("-")
stbEventRanges.Append(empOverLappingDates.Last.EventDate.ToShortDateString())
End If
So, here's my solution
Public Function FindDateRanges(ByRef listOfDates As List(Of DateTime)) As List(Of DefinedDateRange)
'Find approved date ranges
Dim DateRange = New DefinedDateRange(Nothing)
Dim DefDateRanges As New List(Of DefinedDateRange)
If listOfDates.Count > 0 Then
DateRange = New DefinedDateRange(listOfDates(0), listOfDates(0)) 'First start/end date
If listOfDates.Count > 1 Then 'Only one time off date in list
For index As Integer = 1 To listOfDates.Count - 1
If listOfDates(index) = listOfDates(index - 1).AddDays(1) Then
DateRange.dtEnd = listOfDates(index)
Else
DefDateRanges.Add(DateRange)
DateRange = New DefinedDateRange(listOfDates(index), listOfDates(index)) 'Next Start/end date
End If
Next
DefDateRanges.Add(DateRange)
Else
DefDateRanges.Add(DateRange)
End If
End If
Return DefDateRanges
End Function
Class DefinedDateRange
Public dtStart As DateTime, dtEnd As DateTime
Public Sub New(dateStart As DateTime, Optional dateEnd As DateTime = Nothing)
Me.dtStart = dateStart
Me.dtEnd = dateEnd
End Sub
End Class
Related
I have a large amount of date FROM and TO pairs, and I need to count all the days within them. But if two ranges are overlapping then the overlapping days should not be counted twice.
Here's the code that counts all days that I have:
Dim total_days_used = 0
For Each row As DataRow In MY_DATA.Tables(0).Rows
Dim total_days As Double = 0
Dim date_from = MY_FROM_DATE_FROM_DATA
Dim date_to = MY_TO_DATE_FROM_DATA
Dim span = date_to - date_from
total_days = span.TotalDays '=4
total_days_used += total_days
Next
I can't figure out an easy way to subtract the overlapping days though or even keep track of them. I guess that would be one way to go, the other would be to combine overlapping ranges until I end up with a set of ranges where there are no overlaps but that seems way too complicated as well. There should be a simple way to do this?
Something like this should work.
We first order the ranges to know if the last overlaps the current.
And then count the overlapping days and substract that from the total.
+1 days if you want the range to be inclusive otherwise remove that.
Private Sub Main()
Dim ranges = New List(Of Range)() From { _
{New Range(New DateTime(2000, 1, 1), New DateTime(2000, 1, 30))}, _
{New Range(New DateTime(2000, 1, 28), New DateTime(2000, 2, 3))} _
}
CountNonOverlappingsDays(ranges).Dump() '34 days
End Sub
Private Function CountNonOverlappingsDays(ranges As IEnumerable(Of Range)) As Integer
Dim isFirst = True
Dim last As Range = Nothing
Dim overlapping As Integer = 0
Dim total As Integer = 0
For Each current In ranges.OrderBy(Function(r) r.[To])
total += CInt((current.[To] - current.From).TotalDays) + 1 '+1 if we want Inclusive count
If isFirst Then
isFirst = False
last = current
Continue For
End If
If (last.From <= current.[To]) AndAlso (last.[To] >= current.From) Then
Dim start = current.From
Dim [end] = last.[To]
overlapping += CInt(([end] - start).TotalDays) + 1 '+1 if we want Inclusive count
End If
last = current
Next
Return total - overlapping
End Function
Public Class Range
Public Sub New([from] As DateTime, [to] As DateTime)
[From] = [from]
[To] = [to]
End Sub
Public Property [From]() As DateTime
Get
Return m_From
End Get
Set
m_From = Value
End Set
End Property
Private m_From As DateTime
Public Property [To]() As DateTime
Get
Return m_To
End Get
Set
m_To = Value
End Set
End Property
Private m_To As DateTime
End Class
Use the following (or similar DateRange class).
Class DateRange
Implements IEnumerable(Of DateTime)
Public Sub New(startDate As DateTime, endDate As DateTime)
me.StartDate = startDate
me.EndDate = endDate
End Sub
Public ReadOnly Property StartDate() As DateTime
Public ReadOnly Property EndDate() As DateTime
Public Function GetEnumerator() As IEnumerator(Of DateTime) Implements IEnumerable(of DateTime).GetEnumerator
Return Enumerable.Range(0, 1 + EndDate.Subtract(StartDate).Days).[Select](Function(offset) StartDate.AddDays(offset)).GetEnumerator()
End Function
Private Function IEnumerable_GetEnumerator() As IEnumerator Implements IEnumerable.GetEnumerator
Return GetEnumerator()
End Function
End Class
The important part of this class is that it is enumerable. That is, it returns the sequence of dates between the start and end dates (inclusive), when used in a for each loop (among other things).
Then you can use code like this to get what you want:
Dim ranges = New List(Of DateRange)()
ranges.Add(New DateRange(#2017/1/1#,#2017/1/10#))
ranges.Add(New DateRange(#2017/1/8#,#2017/1/20#))
Dim merged = ranges.SelectMany(Function(r) r.AsEnumerable()).Distinct().OrderBy(Function(dt) dt)
Console.WriteLine($"{merged.Count()} days: ")
For Each [date] As DateTime In merged
Console.WriteLine([date].ToShortDateString())
Next
Console.ReadLine()
This uses the LINQ SelectMany function to flatten the lists of dates (created by the IEnuemrable DateRange) from all the DateRange instances in the list to a single list of DateTime. It then gets the distinct (unique) values, and sorts the list.
The output shows output from a list containing 2 DateRange instances. The first is from Jan 1, 2017 to Jan 10, 2017, the second from Jan 8, 2017 to Jan 20, 2017. These ranges overlap on the 8th, 9th, and 10th. As you can see, those overlapped dates are only included once.
The following output is produced:
20 days:
1/1/2017
1/2/2017
1/3/2017
1/4/2017
1/5/2017
1/6/2017
1/7/2017
1/8/2017
1/9/2017
1/10/2017
1/11/2017
1/12/2017
1/13/2017
1/14/2017
1/15/2017
1/16/2017
1/17/2017
1/18/2017
1/19/2017
1/20/2017
Try this:
Dim range As New List(Of DateTime)()
For Each row As DataRow In MY_DATA.Tables(0).Rows
Dim date_from = MY_FROM_DATE_FROM_DATA
Dim date_to = MY_TO_DATE_FROM_DATA
range.AddRange(Enumerable.Range(0, (date_from-date_to).TotalDays).Select(d => date_from.AddDays(d))
Next
Dim total_days_used As Integer = range.Distinct().Count()
The magic is in two parts. The first part uses Enumerable.Range() to actually project all of the dates in each range, so we can add them to a list. The second part then just takes the distinct members of that list and counts them.
Private Shared Function ValidateDate(dataTable As DataTable) As Boolean
Dim Currentdate As Date = Date.Now()
Dim Rows As New List(Of String)
Dim result As Boolean = True
For Each Row As DataRow In dataTable.Rows
If Not Currentdate Is Then
Next
Return result
End Functionhere
I want to compare rows of datecolumn of DataTable with the current date and return whether or not it's matches the current date.
code:
Private Shared Function ValidateDate(dataTable As DataTable) As Boolean
Dim Currentdate As Date = Today
Dim result As Boolean = True
For Each row As DataRow In dataTable.Rows
If Not CDate(row.Item("ReportDate")) >= Currentdate Then
result = False
Exit For
End If
Next
Return result
End Function
Thank you for your responses .I used this method to validate date in every row of datecolumn
Maybe this could help (not tested but should work)...This approach gives you a list with the rows who matched your criteria
Dim Currentdate As Date = Today
Dim lst as New List(of DataRow)
For each row as DataRow in datatable.Rows
If CDate(row.Items(index or columname)) = currentdate Then
lst.Add(row)
Next
return lst
Notice you have time in date datatype, which will be 0:00:00 if you dont give it explicitly.
(Should be no Problem, if all valuesa are only dates "with default 0:00:00 time") If not you will **get only true if date & time are the same **!
So you should use Today instead of Date.Now().. Every time you call Date.Now() you get the actual date & actual time. With Today you get actual date and time = 0:00:00.
I have this one:
Public Function WorkingDays(StartDate As Date, _
ByVal EndDate As Date, _
Optional ByVal Holidays As Range, _
Optional ByVal Workdays As Variant) As Long
Dim mpDays As Long
Dim mpHolidays As Variant
Dim mpWorkdays As Variant
Dim i As Long
If Not Holidays Is Nothing Then mpHolidays = Application.Transpose(Holidays)
If IsMissing(Workdays) Then
mpWorkdays = Array(2, 3, 4, 5, 6)
Else
mpWorkdays = Workdays
End If
For i = StartDate To EndDate
If Not IsError(Application.Match(Weekday(i), mpWorkdays, 0)) Then
If IsError(Application.Match(i, mpHolidays, 0)) Then
mpDays = mpDays + 1
End If
End If
Next i
WorkingDays = mpDays
End Function
but it is very slow,
I use this function in my Workbook and my sheet I've 130K records. How can it be improved?
Have you seen that Excel has the NETWORKDAYS and the WORKDAYS functions?
Instead of looping through the dates from StartDate to EndDate which is very slow, why not work out the number of week days between the two dates and then loop through the holidays to see if each date falls between StartDate and EndDate?
This link has formula version of Networkdays (without using the actual Networkdays function) and a VBA version: http://www.cpearson.com/excel/betternetworkdays.aspx
I change method to calculate work days, it's work in 00:00:32
Public Function WrkDaysCount(StartDate As Date, _
ByVal endDate As Date) As Long
Dim DayStart As Long
Dim DayEnd As Long
Dim daytot As Long
Dim Nrweeks As Long
DayStart = Weekday(StartDate, vbMonday)
DayEnd = endDate - StartDate + DayStart
Nrweeks = Int(DayEnd / 7)
daytot = DayEnd - (fest * 2) - DayStart + 1
WrkDaysCount = daytot
End Function
Im trying to make Recursive Function in VB.net
The Function are going to add some day to Special date . also if there is a
friday between the range of added day its going to count them and adding them to
date again.
it must be Recursive because if there way a friday after adding more than 7 day
it also must add another day to date. like this :
origianl date : 5/19/2015
day to be added : 30
added date : 6/18/2015
count of friday between 5/19/2015 and 6/18/2015 : 4
new date after adding fridays : 6/22/2015
count of friday that happen after addinf old friday count : 1
new date and final result : 6/23/2015
i think the last two step must be recursive. this what ive done so far without last two step :
Public Function CountOfFriday(ByVal StartDate As Date, ByVal DayToAdd As Int32) As Int32
Dim newDate As Date = StartDate
Dim OriginalDate As Date = StartDate
Dim friday_count As Integer
For value As Integer = 1 To DayToAdd
OriginalDate = OriginalDate.AddDays(1)
If OriginalDate.DayOfWeek = DayOfWeek.Friday Then
newDate = newDate.AddDays(1)
friday_count += 1
End If
Next
Return friday_count
End Function
and im adding the result of this count to my old date.
now how can i achieve last two steps ?
This returns the final date (hope it helps)
Function CountOfFriday(ByVal StartDate As Date, ByVal DayToAdd As Int32) As Date
Dim newDate As Date = StartDate
Dim OriginalDate As Date = StartDate
Dim friday_count As Integer = 0
For value As Integer = 1 To DayToAdd
OriginalDate = OriginalDate.AddDays(1)
If OriginalDate.DayOfWeek = DayOfWeek.Friday Then
Do
friday_count +=1
Loop until StartDate.AddDays(DayToAdd+friday_count)<StartDate.AddDays(friday_count*7)
Exit for
End If
Next
newDate = newDate.AddDays(DayToAdd+friday_count)
Return newDate
End Function
In Excel using VBA, I need to set a variable to equal a list of all the dates between a start and end date (similar to equaling a range containing multiple values). The catch is only the start and end date are in a range, non of the values in between.
In SQL Server I've used the Sys.Columns table to generate a list of dates between two dates that are not actually stored on that table. Is there a way to do something similar here without having each date between the start and end date written somewhere? I googled for a couple hours and didn't find anything on how to do this.
What I'm attempting to do is have a variable I can do a For Each loop on. So for each date I will check if it exists in another worksheet, if it does nothing will happen, if it does not it will be added.
I've tried:
Dim DatesInSettings As Date
DatesInSettings = StartDate To EndDate
For Each Date In DatesInSettings
'Insert commands here
Next DatesInSetting
But that clearly isn't the answer. Help?
This searches Sheet2 for dates between the start date and end dates on Sheet1 - in cells A1 and B1:
Sub RunDates()
Dim StartDate As Date
Dim EndDate As Date
Dim i As Date
StartDate = Sheet1.Range("A1")
EndDate = Sheet1.Range("B1")
For i = StartDate To EndDate
If WorksheetFunction.CountIf(Sheet2.Range("A1:A5"), i) > 0 Then
Debug.Print i; "- date found"
Else
Debug.Print i; "- date not found"
End If
Next i
End Sub
The following subroutine calls a dictionary that will store all the dates between two given endpoints. Then it uses a simple existence comparison to check if the dates on your list is inside the dictionary's items. If it's not, it's going to print them out as not in the list.
Modify accordingly to suit your needs. ;)
CODE:
Sub GetListOfDates()
Dim StartDate As Date, EndDate As Date
Dim DictOfDates As Object, DateToCheck As Variant, ListOfDates As Variant
Dim Iter As Long
Set DictOfDates = CreateObject("Scripting.Dictionary")
StartDate = "12/31/2013"
EndDate = "01/15/2014"
For Iter = StartDate + 1 To EndDate - 1
With DictOfDates
If Not .Exists(Iter) Then
.Add Iter, Empty
End If
End With
Next Iter
'--Print them somewhere.
'Range("A1").Resize(DictOfDates.Count, 1).Value = Application.Transpose(DictOfDates.Keys)
ListOfDates = Range("B1:B15").Value
For Each DateToCheck In ListOfDates
If Not DictOfDates.Exists(DateToCheck) Then
Debug.Print Str(DateToCheck) + " is not in the list!" '--Or whatever action you want.
End If
Next DateToCheck
Set DictOfDates = Nothing
End Sub
Let us know if this helps. :)
I solved it with a vector.
I hope it helps
Sub Dates_Vector()
Public Dates() As Date
ReDim Dates(End_Dat - Start_Date)
For x = 0 To End_Dat - Start_Date
Dates(x) = Dat_Ini + x
Next x
For Each Date In Dates
'Insert commands here
Next Date
End Sub