Need a Function with Select Case for the Holidays

[Stephen Ray]

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