LinkBack URL
About LinkBacksI've finally got some code put together that does exactly what I want.
However, I forgot that I need to remove holidays!! This code asks the user
which month to set up, and whether they want to include Saturdays and Sundays
before the worksheets for the month are set up. I'm using the CASE structure
to do this.
What I need is a CASE statement that will NOT include holidays. I can have
the serial numbers or dates for the holidays listed somewhere, but I can't
figure out the code to make it work.
Would someone mind taking a look? Thanks Much!!
Here's the full code:
Sub CreateMonth()
Dim SH As Worksheet
Dim wCtr As Long
Dim myDate As Variant
Dim D As Date, Y As Long
Dim N As String
Dim DDate As String
Dim CaseSat As String
Dim CaseSun As String
Worksheets("DMR Master").Activate
Set SH = ActiveSheet
myDate = InputBox(Prompt:="Enter the FIRST DAY of the Month you want to
Create", _
Default:=Format(Date, "mm/dd/yy"))
Msg = "Do You Want to Include Saturdays as a Workday?"
Ans = MsgBox(Msg, vbYesNo)
If Ans = vbNo Then
CaseSat = vbSaturday
Else
CaseSat = ""
End If
Msg = "Do You Want to Include Sundays as a Workday?"
Ans = MsgBox(Msg, vbYesNo)
If Ans = vbNo Then
CaseSun = vbSunday
Else
CaseSun = ""
End If
Application.ScreenUpdating = False
myDate = CDate(myDate)
For iCtr = DateSerial(Year(myDate), Month(myDate), 1) To
DateSerial(Year(myDate), _
Month(myDate) + 1, 0)
Select Case Weekday(iCtr)
Case Is = CaseSat '(Does all days, remove '& does only weekdays)
'do nothing
Case Is = CaseSun '(Does all days, remove ' & does only weekdays)
'do nothing
Case Else
Application.StatusBar = D
SH.Copy after:=Sheets(Sheets.Count)
N = Sheets.Count - 3
'ActiveSheet.Range("A1").Value = D
ActiveSheet.Name = Format(iCtr, "dddd mm-dd")
Range("H4") = Format(iCtr, "mm/dd/yy")
Range("H8") = N
End Select
Next
Sheets(4).Activate
Range("D8") = N
For wCtr = 4 To Worksheets.Count
'If Worksheets(wCtr).Name = Worksheets("Setup").Name Then
'skip it
'Else
Worksheets(wCtr).Activate
Range("D8") = N
'End If
Next wCtr
Worksheets("Setup").Activate
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Register To Reply
Bookmarks