I need help creating an array of dates between 2 dates. I am trying to export holidays from MS Project calendar using the Exceptions object. However, each Calendar.Exception isn't a single date. They can be defined as a range of dates (eg Christmas holidays).
Sub ArrayOfDates()
Dim StartDate As Date, EndDate As Date, aDates() As Date
StartDate = #1/1/2018#
EndDate = #1/31/2018#
'create array of dates inclusive of endpoints
If EndDate > StartDate Then
End If
End Sub
Thanks for all of the suggestions. I went with the approach that eliminated the array:
Sub ExportCalendarHolidays()
Dim calThisPrjCalendar As Calendar, excPeriod As Exception, OutputFileName As String, sOutputLine As String
Dim Period As Date
Set calThisPrjCalendar = ActiveProject.Calendar
OutputFileName = ActiveProject.Path & "\" & "Holidays_" & Format(Now(), "yyyy-mm-dd_hhmmss") & ".csv"
Open OutputFileName For Output As #1
For Each excPeriod In calThisPrjCalendar.Exceptions
For Period = excPeriod.Start To excPeriod.Finish
sOutputLine = Format(Period, "mm/dd/yyyy")
Print #1, sOutputLine
Next Period
Next
'Cleanup
Close #1
End Sub
The code below will create the Array including the start and end date. The lines marked as Debug can be deleted. The loop at the end is just to verify the dates.
Edit: Edited ending loop to look nicer.
Sub ArrayOfDates()
Dim StartDate As Date, EndDate As Date, aDates() As Date
Dim x As Long, y As Long, totalDates As Integer
StartDate = #1/1/2018#
EndDate = #1/31/2018#
DateLoop = StartDate
totalDates = DateDiff("d", StartDate, EndDate)
ReDim aDates(totalDates)
x = 0
Do While DateLoop <= EndDate
aDates(x) = DateLoop
Cells(x + 1, 1).Value = DateLoop ' Debug Line
DateLoop = DateAdd("d", 1, DateLoop)
x = x + 1
Loop
For y = 0 To UBound(aDates)
Cells(y + 1, 3).Value = aDates(y) ' Debug Line
Cells(y + 1, 4).Value = "Array Spot: " & y 'Debug Line
Next y
End Sub
To just get all the dates, you could do something like.
Dim dtDate as Date, dtStartDate as date, dtEndDate as Date
dtStartDate = #1/1/2018#
dtEndDate = #1/31/2018#
For dtDate = dtStartDate To dtEndDate
'code to do each date
Next dtDate
Related
I have a form where the user will input the start and end date. With this date, I need to enter all the dates from start date to end date in another worksheet DailyData. I am using below code but somehow it's not working. The code is not giving any error as well.How to make it work
Sub day()
Dim MaxGain As Workbook
Dim Main As Worksheet
Dim DailyData As Worksheet
Dim StartDate As Date
Dim EndDate As Date
Dim i As Long
Set MaxGain = Excel.Workbooks("MaxGain.xlsm")
Set Main = MaxGain.Worksheets("Main")
Set DailyData = MaxGain.Worksheets("DailyData")
StartDate = Main.Range("B5").Value
EndDate = Main.Range("B6").Value
i = 1
For DateLooper = StartDate To EndDate
DailyData.Cells(i, "A") = DateLooper
i = i + 1
Next DateLooper
End Sub
Excel has few methods of creating series in the Home tab > Editing > Fill
Sub Day()
[DailyData!A1] = [Main!B5].Value
[DailyData!A:A].DataSeries Stop:=[Main!B6]
End Sub
https://msdn.microsoft.com/en-us/vba/excel-vba/articles/range-dataseries-method-excel
Sub day()
Dim MaxGain As Workbook
Dim Main As Worksheet
Dim DailyData As Worksheet
Dim StartDate As Date, EndDate As Date, newDate as date
Dim i As Long, DaysBetween as long
Set MaxGain = Excel.Workbooks("MaxGain.xlsm")
Set Main = MaxGain.Worksheets("Main")
Set DailyData = MaxGain.Worksheets("DailyData")
StartDate = Main.Range("B5").Value
EndDate = Main.Range("B6").Value
DaysBetween = DateDiff("d", StartDate, EndDate)
newDate = StartDate
for i = 1 to DaysBetween
DailyData.Cells(i, "A") = newDate
newDate = DateAdd ("d", 1, newDate)
next i
End Sub
You need to reference DateLooper as :
Dim DateLooper As Long
Then in your For Loop :
DailyData.Cells(i, "A") = StartDate + DateLooper
I am trying to write a script that searches a list of dates, and identifyies how long date gaps are. I'm new to VBA, and this may be completely wrong, but after referencing several sites, here is what I came up with:
Sub IdentifyGaps()
Dim startdate As Date 'first date in column
Dim enddate As Date 'last date in column
Dim ust As Date 'first date of unemployment
Dim i As Long
ust = ActiveCell.Offset(1, 0).Value
With Sheet6
startdate = [A1]
enddate = .Cells(.Rows.Count, "A").End(xlUp).Value
For i = startdate To enddate
If ust <> DateAdd("d", 1, i) Then
Sheet6.[C1].Value = DateDiff("d", i, ust)
End If
Next i
End With
End Sub
I'm not receiving an error, but the macro is not working properly. Right now, it's returning -43074 when it should be returning 15. Any help would be much appreciated!
Here is a screenshot of the data, with the lone date gap it should pick up.
Sub IdentifyGaps()
Dim ws As Worksheet
Dim Date1 As Long, Date2 As Long, Gap As Long, lRow As Long
Set ws = Sheet6
lRow = ws.Range("C" & Rows.Count).End(xlUp).Row
For x = 1 To ws.Range("A" & Rows.Count).End(xlUp).Row
Date1 = ws.Cells(x, 1).Value
Date2 = ws.Cells(x + 1, 1).Value
Gap = DateDiff("d", Date1, Date2)
If Gap > 1 Then
ws.Range("C" & lRow).Value = Gap
lRow = lRow + 1
End If
Next x
Looking at my calendar, I believe your expected result should actually be 17, not 15. This code will return the gap value as a Long value with which you can do whatever you want.
'Reads a column of dates and returns the length of the first gap found
Function IdentifyGaps() As Long
Dim StartDate As Date
Dim EndDate As Date
'This Variable is not needed for this solution, it is instead replaced by Gap
'Dim ust As Date
Dim Gap As Long
'Read cell values into an array for more efficient operation
Dim ReadArray() As Variant
ReadArray = Sheet6.Range("A1").CurrentRegion
Dim LastRow As Long
LastRow = UBound(ReadArray, 1)
StartDate = ReadArray(1, 1)
EndDate = ReadArray(LastRow, 1)
'ThisDate and PreviousDate are declared explicitly to highlight program flow
Dim Row As Long
Dim ThisDate As Date
Dim PreviousDate As Date
For Row = 2 To UBound(ReadArray, 1)
ThisDate = ReadArray(Row, 1)
PreviousDate = ReadArray(Row - 1, 1)
Gap = ThisDate - PreviousDate
If Gap > 1 Then Exit For
Gap = 0
Next Row
IdentifyGaps = Gap
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ProveIt()
Debug.Print IdentifyGaps
End Sub
I managed to use the following formula to calculate the net working days between two dates.The problem is i would like to make it possible for the user to enter what days of the week the person works in another cell and automatically update the formula. Just to make it more user friendly, and prevent the user from messing with the formula. Is there anyway to enter the string(12345) in another cell and have the formula update automatically?
Thanks in advance
Option Explicit
'
' This function tells you how many working days are there between 2 given dates.
' You can use this to calculate working days in countries where saturday and sunday are
' not usually holidays.
'
Function NetWorkingDays(sDateRng As Range, eDateRng As Range, workingDays As String, _
Optional HolidayRng As Range) As Long
'
' e.g. use: =NetWorkingDays($A$1,$A$2,"12356")
' will tell you the count of mondays, tuesdays, wednesdays, fridays and saturdays
' between the dates in $A$1 and $A$2
'
' e.g. use: =NetWorkingDays($A$1,$A$2,"12356",$H$2:$H$50)
' will tell you the count of mondays, tuesdays, wednesdays, fridays and saturdays
' between the dates in $A$1 and $A$2, excluding any holidays (listed as dates) in
' the range $H$2:$H$50
'
' You can also count the number of individual days between dates:
' =NetWorkingDays($A$1,$A$2,"2")
' will tell you the number of tuesdays between those two dates
'
Dim sDate As Date, eDate As Date, Holidays() As Variant
Dim nHolidays As Long
Dim totalDays, startDay As Long, endDay As Long
Dim totWeeks As Long, extraDays As Long
Dim curWeekday As Long
Dim i, retVal As Long
'
If (Not IsDate(sDateRng.Value)) Then
sDate = 0#
Else
sDate = sDateRng.Value
End If
'
If (Not IsDate(eDateRng.Value)) Then
eDate = 0#
Else
eDate = eDateRng.Value
End If
'
If (Not HolidayRng Is Nothing) Then
nHolidays = HolidayRng.Cells.Count
ReDim Holidays(0 To nHolidays - 1)
Holidays = HolidayRng.Value2 ' CAREFUL - this automatically assumes dates in the range!
Else
nHolidays = 0
End If
'
totalDays = eDate - sDate + 1
startDay = Weekday(sDate, vbMonday)
endDay = Weekday(eDate, vbMonday)
'
' First calculate the number of whole weeks in the date span.
' Whole weeks are defined as all weeks that start on Monday and
' end on Sunday.
'
If (startDay = 1) Then
If (endDay = 7) Then
extraDays = 0
Else
extraDays = 7 - endDay
End If
Else
If (endDay = 7) Then
extraDays = 7 - startDay + 1
Else
extraDays = 7 - startDay + 1 + endDay
End If
End If
totWeeks = (totalDays - extraDays) / 7
'
' Now determine how many "extra" days are on either side of
' the whole weeks. Include only those "extra" days that are
' a part of the "workingDays" string.
'
extraDays = 0
If (startDay <> 1) Then
For i = startDay To 7
If (InStr(workingDays, CStr(i)) > 0) Then
extraDays = extraDays + 1
End If
Next i
End If
If (endDay <> 7) Then
For i = 1 To endDay
If (InStr(workingDays, CStr(i)) > 0) Then
extraDays = extraDays + 1
End If
Next i
End If
'
retVal = totWeeks * Len(workingDays) + extraDays
'
' Now subtract out the holidays if applicable to the period in question
'
If (nHolidays > 0) Then
For i = LBound(Holidays) To UBound(Holidays)
If (InStr(workingDays, Weekday(Holidays(i, 1), vbMonday)) > 0 And _
Holidays(i, 1) >= sDate And Holidays(i, 1) <= eDate) Then
retVal = retVal - 1
'Debug.Print Format(Holidays(i, 1), "dd mmm, yyyy") & " was removed: it is a " & Format(Holidays(i, 1), "dddd")
Else
'Debug.Print Format(Holidays(i, 1), "dd mmm, yyyy") & " was not removed: it is a " & Format(Holidays(i, 1), "dddd")
End If
Next i
End If
'
NetWorkingDays = retVal
End Function
I am a newbie in vba and I am trying to get in vba all dates between 2 dates, for example I will call the function with the parameters 01-01-2015 and 15-01-2015, and I will get in return an array with all the dates possibles, i.e :
01-01-2015
02-01-2015
03-01-2015
.....
15-01-2015
I didn't find the answer on the forums, so thanks in advance for your help.
you can simply convert the dated in long and make loop(+1) and get all dated between 2 dates(convert that to date again)
Sub Calling()
Dim test
test = getDates(#1/25/2015#, #2/5/2015#)
End Sub
Function getDates(ByVal StartDate As Date, ByVal EndDate As Date) As Variant
Dim varDates() As Date
Dim lngDateCounter As Long
ReDim varDates(1 To CLng(EndDate) - CLng(StartDate))
For lngDateCounter = LBound(varDates) To UBound(varDates)
varDates(lngDateCounter) = CDate(StartDate)
StartDate = CDate(CDbl(StartDate) + 1)
Next lngDateCounter
getDates = varDates
ClearMemory:
If IsArray(varDates) Then Erase varDates
lngDateCounter = Empty
End Function
Function to get all dates from given range
Function GetDatesRange(dateStart As Date, dateEnd As Date) As Collection
Dim dates As New Collection
Dim currentDate As Date
currentDate = dateStart
Do While currentDate <= dateEnd
dates.Add currentDate
currentDate = DateAdd("d", 1, currentDate)
Loop
Set GetDatesRange = dates
End Function
Sample usage
Dim dateStartCell as Range, dateEndCell as Range
Dim allDates as Collection
Dim currentDateSter as Variant
Dim currentDate as Date
Set dateStartCell = ActiveSheet.Cells(3, 3)
Set dateEndCell = ActiveSheet.Cells(3, 6)
Set allDates = GetDatesRange(dateStartCell.Value, dateEndCell.Value)
For Each currentDateSter In allDates
currentDate = CDate(currentDateSter)
'Do something with currentDate
Next currentDateSter
An array 'sn' containing all dates from 01-01-2015 to 15-01-2015.
Msgbox introduced to illustrate the result.
Sub M_snb()
sn = Evaluate("index(text(datevalue(""01-01-2015"")+row(1:" & DateDiff("d", CDate("01-01-2015"), CDate("15-01-2015")) & ")-1,""dd-mm-yyyy""),)")
MsgBox sn(1, 1) & vbLf & sn(2, 1) & sn(UBound(sn), 1)
End Sub
Maybe this.
Function udf_Array_of_Dates(dtSTART As Date, dtEND As Date, rDATEs As Range)
Dim dt() As Date, r As Range, d As Long
For Each r In rDATEs
If r.Value >= dtSTART And r.Value <= dtEND Then
d = d + 1
ReDim Preserve dt(1 To d)
dt(d) = r.Value
End If
Next r
udf_Array_of_Dates = dt
End Function
Proof & syntax:
If you just want to print the dates between two date in excel then my Suggestion is to you try below the code.
Sub DateFill()
Dim Start_Date As Date
Dim End_Date As Date
Dim Number_Of_Days As Integer
Start_Date = InputBox(prompt:="Enter the Start Date", Title:="Date Print", Default:="3/1/2013")
End_Date = InputBox(prompt:="Enter the End Date", Title:="Date Print", Default:="3/23/2013")
Range("A1").Value = Start_Date
'Range("B1").Value = End_Date
Range("A1").Select
Number_Of_Days = DateDiff("d", Start_Date, End_Date) ' Return Day
Number_Of_Days = Number_Of_Days + 1
'Range("C1").Formula = "=DATEDIF(A1, B1, ""D"") "
Selection.AutoFill Destination:=Range("A1:A" & Number_Of_Days), Type:=xlFillDefault
Range("A1:A" & Number_Of_Days).Select
End Sub
Here you have avoid the use of Loop that save the execution time.
I'm trying to loop through a column of dates, and any date that is within two other set dates (First Day of Week, Last Day of Week) or (First Day of Month, Last Day of Month).
When I go to assign the date in the column to a variable, I get a type mismatch error.
Sub JobsDue(ByRef DateStart As Date, ByRef DateEnd As Date)
Dim LastRow As Integer
LastRow = Sheet1.Cells(Rows.count, "B").End(xlUp).Row
Dim JobDueDate As String
Dim JobPN As String
For i = 10 To LastRow
JobDueDate = Sheet1.Range("B" & 10, "B" & i).Value (ERROR OCCURS HERE)
JobPN = Sheet1.Range("C" & 10, "C" & i).Value
If (JobDueDate) >= DateStart And (JobDueDate) <= DateEnd Then
lbJobsDue.AddItem (JobPN & "," & CDate(JobDueDate))
End If
Next i
End Sub
Private Sub comboxJobsDue_Change()
If comboxJobsDue.Value = "This Week" Then
StartOfWeek = Date - Weekday(Date) + 2
endofweek = Date - Weekday(Date) + 6
lblJobsDue.Caption = (StartOfWeek) & "-" & (endofweek)
Call JobsDue((StartOfWeek), (endofweek))
ElseIf comboxJobsDue.Value = "Next Week" Then
StartOfWeek = Date - Weekday(Date) + 9
endofweek = Date - Weekday(Date) + 13
lblJobsDue.Caption = (StartOfWeek) & "-" & (endofweek)
ElseIf comboxJobsDue.Value = "This Month" Then
FirstDayInMonth = DateSerial(Year(Date), Month(Date), 1)
LastDayInMonth = DateSerial(Year(Date), Month(Date) + 1, 0)
lblJobsDue.Caption = FirstDayInMonth & "-" & LastDayInMonth
ElseIf comboxJobsDue.Value = "Next Month" Then
FirstDayInMonth = DateSerial(Year(Date), Month(Date) + 1, 1)
LastDayInMonth = DateSerial(Year(Date), Month(Date) + 2, 0)
lblJobsDue.Caption = FirstDayInMonth & "-" & LastDayInMonth
End If
End Sub
The error occurs on Line 7, when I run the program to debug, JobDueDate gets a date but it is in the format of "9/25/2013", the other dates are of the format 8/18/2014 WITHOUT quotation marks. Can anyone explain to me why this error is happening and how I can go about fixing it?
Thanks in advance, Evan
See the line declaration reading "Dim JobDueDate As String" (line 4 I think) You're telling the system you want it as a string... Perhaps you want Dim JobDueDate As Date so you can use date functions on it.
DateStart and End are being passed in as dates so they would error on the code calling this sub if they passed in invalid dates.
Additionally, you appear to be attempting to assign a range of dates to a date field. You either need a collection of dates or an array of dates to handle this.