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
|