#1
|
|||
|
|||
Need a Function with Select Case for the Holidays
Hello!
I have written a really simple Macro that works very well but I would like to make it more compact and elegant. I would like to know how to make a function with a Select Case for the Holidays. I just cannot figure that out. After I know how to do that, I want to make it more and more compact. This Macro Calculates a Date, it takes the current date and adds 14 working days, excluding weekends and Holidays. The current date is not counted. Then it puts that calculated date into the clipboard and shows a box for about 1 second. Thanks in advance, Sub Macro5() 'The Idea is to Find Weekdays, then find Holidays that are Weekdays ' Macro5 Macro ' Dim TodaysDate As Date Dim DateBirthday As Date TodaysDate = Date Dim count As Integer count = 14 Dim TestDay As Date TestDay = Date Dim vDate As Date vDate = Date Dim DayOfWeekNumber As Integer HolidayA = CDate("01/01/21") HolidayB = CDate("01/02/21") HolidayC = CDate("01/30/21") 'The 1st Day Never Counts, so advance one day. If TodaysDate = Date Then vDate = DateAdd("d", 1, vDate) 'Add 1 day to vdate End If Do While count > 0 DayOfWeekNumber = Weekday(vDate) '1 for Sunday 2 for Monday 3 for Tuesday... 6 for Friday 7 forSaturday 'If TodaysDate is not a Weekend, Then it must be a Weekday. If Not ((DayOfWeekNumber = 1) Or (DayOfWeekNumber = 7)) Then 'Weekday count = count - 1 If ((vDate = HolidayA) Or (vDate = HolidayB) Or (vDate = HolidayC)) Then vDate = DateAdd("d", 1, vDate) 'Add 1 day to vdate End If Else 'Weekend End If If count > 0 Then vDate = DateAdd("d", 1, vDate) 'Add 1 day to vdate End If Loop Dim strBothItems As String Dim firstPart As String Dim datePart As String firstPart = "Fourteen Days from Today " datePart = vDate strBothItems = firstPart & datePart Selection.TypeText vDate Selection.MoveLeft Unit:=wdCharacter, count:=10 Selection.Find.ClearFormatting With Selection.Find .Text = "-" .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Application.StatusBar = strBothItems Selection.MoveLeft Unit:=wdCharacter, count:=3 Selection.MoveRight Unit:=wdCharacter, count:=10, Extend:=wdExtend Selection.Copy Application.StatusBar = strBothItems ActiveDocument.ActiveWindow.Caption = strBothItems & " " & ActiveDocument 'MsgBox strBothItems & " On Your ClipBoard" 'Application.StatusBar = strBothItems Dim AckTime As Integer, InfoBox As Object Set InfoBox = CreateObject("WScript.Shell") 'Set the message box to close after 3 seconds AckTime = 1 Select Case InfoBox.Popup(strBothItems & " On Your ClipBoard", _ AckTime, "On Your ClipBoard", 0) Case 1, -1 'Exit Sub End Select Application.StatusBar = strBothItems End Sub |
#2
|
||||
|
||||
Well it could certainly be simplified
Code:
Option Explicit Sub Macro6() 'The Idea is to Find Weekdays, then find Holidays that are Weekdays 'Graham Mayor - https://www.gmayor.com - Last updated - 05 Jan 2021 Dim Count As Integer Dim TestDay As Date Dim sMessage As String Dim vHolidays As Variant Dim i As Integer, j As Integer Dim oRng As Range Dim dDate As DataObject vHolidays = Array("01/01/21", "01/02/21", "01/30/21") 'add the holidays to the array Count = 14 TestDay = Date 'CDate("01/01/21") For i = 1 To 14 If Weekday(TestDay + i) = 1 Or Weekday(TestDay + i) = 7 Then Count = Count + 1 'if added day is at the weekend add another day If Weekday(TestDay + Count) = 1 Or Weekday(TestDay + Count) = 7 Then Count = Count + 1 End If Next i For j = 0 To UBound(vHolidays) If TestDay = CDate(vHolidays(j)) Then Count = Count + 1 'probably unnecessary but if added day is at the weekend add another day If Weekday(TestDay + Count) = 1 Or Weekday(TestDay + Count) = 7 Then Count = Count + 1 End If Next j TestDay = DateAdd("d", Count, TestDay) 'Add count to TestDay Selection.TypeText TestDay 'optional as the date is written to the clipboard Set dDate = New DataObject dDate.SetText TestDay dDate.PutInClipboard sMessage = "14 Working Days from Today - " & TestDay MsgBox sMessage, vbInformation, "Add working days" Set dDate = Nothing End Sub
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#3
|
||||
|
||||
For a non-macro solution, see Handling Weekends and Holidays in Calculated Dates in my Microsoft Word Date Calculation Tutorial: https://www.msofficeforums.com/word/...-tutorial.html
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#4
|
|||
|
|||
Graham has shown you a way using and array. Paul, using fields. You don't really need a select case for the holidays. You could also use an error handler and leverage the fact that keys in collections can't be duplicated:
Code:
Sub Test() MsgBox Format(fcnAdvancedDate("1/6/2021"), "MMMM dd, yyyy") MsgBox fcnAdvancedDate End Sub Function fcnAdvancedDate(Optional StartDate As Variant, Optional DaysToCount As Long = 14) As Date Dim lngIndex As Long Dim dateTmp As Date Dim varHolidays As Variant Dim colHolidays As New Collection varHolidays = Array("01/01/21", "01/18/21", "02/15/21") dateTmp = Date If IsDate(StartDate) Then dateTmp = StartDate For lngIndex = 0 To UBound(varHolidays) colHolidays.Add varHolidays(lngIndex), varHolidays(lngIndex) Next lngIndex lngIndex = 0 Do dateTmp = DateAdd("d", 1, dateTmp) Select Case Weekday(dateTmp) Case 2 To 6 On Error Resume Next colHolidays.Add Format(dateTmp, "MM/dd/yy"), Format(dateTmp, "MM/dd/yy") If Err.Number = 0 Then lngIndex = lngIndex + 1 colHolidays.Remove (colHolidays.Count) End If End Select Loop Until lngIndex = DaysToCount fcnAdvancedDate = dateTmp lbl_Exit: Exit Function End Function Last edited by gmaxey; 01-05-2021 at 04:45 PM. |
#5
|
|||
|
|||
gmayor, macropod, gmaxey, Thank you very much, I appreciate your efforts. It will take some time to read, study and digest your ideas. So I will be studying Arrays now too. I will get back to you, but it will take some time.
I really need some good books to study. Last edited by Stephen Ray; 01-05-2021 at 04:44 PM. Reason: too much white space |
#6
|
|||
|
|||
GMayor, I copied the code you supplied and got an error that I don't know how to fix.
This is what my code looks like: End Sub Option Explicit Sub Macro7() 'The Idea is to Find Weekdays, then find Holidays that are Weekdays 'Graham Mayor - Graham Mayor - Home Page - Last updated - 05 Jan 2021 Dim Count As Integer Dim TestDay As Date Dim sMessage As String Dim vHolidays As Variant Dim i As Integer, j As Integer Dim oRng As Range Dim dDate As DataObject dDate As DataObject is highlighted in Blue and it says: Compile Error User-Defined Type not defined. Where did I go wrong? |
#7
|
|||
|
|||
You need a reference to the MicrosoftForms 2.0 object library.
You said you needed a function. Why don't you use the function I gave you? |
#8
|
|||
|
|||
GMaxey, I got the code you supplied to work. I understand some of your code. Very interesting, an Array. And two boxes appear. I have enough to go on now. The Select Case you used tests for weekdays.
Concerning this line: fcnAdvancedDate(Optional StartDate As Variant, Optional DaysToCount As Long = 14) As Date Where do I go to learn about the parts to the right and left of the comma ? And the parentheses ? Thanks, |
#9
|
|||
|
|||
GMaxey, I didn't see your previous post. I was busy studying your code! I appreciate your help. And right now, I don't want you to write any more code for me because I want to do it. But I do need your help understanding the format/syntax of
fcnAdvancedDate(Optional StartDate As Variant, Optional DaysToCount As Long = 14) As Date Later, I think I will be able to add another Select Case to your code for the Holidays found on the Weekends. And later I will figure out how to choose Friday or Monday for the day off work in those cases when the holiday falls on a weekend. If the holiday falls on Saturday, the day off work is always Friday. If the holiday falls on Sunday, the day off work is always Monday. But I've got to do it one step at a time, get one thing working well, then do the next step. Thanks again, |
#10
|
|||
|
|||
They are called parameters and in that code, they are optional. See if this helps:
Code:
Sub SubSimple() 'You can run this sub directly. MsgBox "Hello Stephen" End Sub Sub WithParameters(strGreeting As String, strName As String) 'This sub has required parameters it can only be called by another sub passing arguments. MsgBox strGreeting & " " & strName End Sub Sub WithOptionalParameters(Optional strGreeting As String = "Hello", Optional strName As String = "Stephen") 'This sub has optional parameters it can only be called by another sub with or with passing arguments. MsgBox strGreeting & " " & strName End Sub Function fcnOffsetDate(Optional StartDate, Optional lngOffset As Long = 7) As Date 'Functions return a value to the the calling procedure. 'This functions have optional parameters. The optional parameters define the defaults. Dim dateTmp As Date dateTmp = Date If IsDate(StartDate) Then dateTmp = StartDate fcnOffsetDate = DateAdd("d", lngOffset, dateTmp) End Function Sub CallingSub() 'Call each of the examples. Step through this procedure using the F8 key. SubSimple WithParameters "Hello", "Steven Ray" 'the arguments must be passed. WithOptionalParameters 'The parameters are optional so no arguments have to be passed. MsgBox fcnOffsetDate 'The parameters are optional so no arguments have to be passed. MsgBox fcnOffsetDate("12/31/2021", 25) 'We are passing optional arguments. End Sub |
#11
|
|||
|
|||
GMaxey, Thank you very much. I just finished work, I am exhausted. So I cannot look at your code right now. I have several irons in the fire. But be sure, I will study your code, write a new Macro, and show you later. These are the times that try mens' souls.
|
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Can Select Case be used to defined the Value of an item in a drop down list? | mbews | Word VBA | 10 | 10-08-2020 05:04 AM |
Toggle between upper case, lower case, etc... by one single macro on a Mac, to emulate Shift + F3 on | gloub | Word VBA | 2 | 01-30-2019 12:40 PM |
SENDKEYS with vbYesNoCancel and Select Case | kiwimtnbkr | Word VBA | 31 | 06-11-2018 04:56 AM |
Use function to select another worksheet | eugeneradial | Excel | 2 | 04-27-2017 04:53 AM |
Help with Case and Select case | brent chadwick | Word VBA | 34 | 10-18-2015 02:13 PM |