0
目標是我在VBA Excel中製作一個小工具。如何在VBA和超鏈接任務工作表中僅突出顯示工作表中的目標假日
任務描述如下：
1-請在VBA代碼中的功能，將突出在所提供的日曆中的固定節日（新年01/01，勞動節01/05，聖誕節25/12，Christmas Holiday 26/12）
2-在VBA代碼中創建一個函數，該函數將突出顯示所提供日曆（復活節星期一，耶穌受難日）中的浮動假日。
3-工作簿中的工作表應該通過VBA代碼超級鏈接到工作日（工作日是從「星期一到星期五」），這裏也有一個條件。如果未來日曆中的工作日恰好是固定假日或浮動假期，例如星期二有新年，那麼將會出現假期，在這種情況下，工作表不應在該假期提供。換句話說，工作表的任務僅在工作日內執行。因此，如果有假期（不論是固定假期還是浮動假期），包含任務信息的任務工作表將不可用。
我的問題是，我沒有太多的VBA知識。通過互聯網搜索我已經找到了功能，但如何整合它們來實現上述？
我的代碼，到目前爲止，發現的東西是如下：
Public Sub Worksheet_Change(ByVal Target As Range)
Dim mth As Integer, b As Integer, dt As Integer, M As Integer, x As Integer, _
w As Integer, Y As Integer, Days As Integer, iRow As Integer
Dim dateDay1 As Date, dateLeapYear As Date, calYearCell As Range
Dim ws As Worksheet
Dim monthName(1 To 12) As String, weekDay(1 To 7) As String
On Error GoTo ResetApplication
'will enable events (worksheet change) on error
'check validity of worksheet name:
If Not ActiveSheet.Name = "Calendar" Then
MsgBox "Please name worksheet as 'Calendar' to continue"
Exit Sub
End If
Set ws = Worksheets("Calendar")
'address of cell/range which contains Calendar Year:
Set calYearCell = ws.Range("H7")
'At least one cell of Target is within the range - calYearCell:
If Not Application.Intersect(Target, calYearCell) Is Nothing Then
'turn off some Excel functionality so the code runs faster
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
If calYearCell = "" Then
MsgBox "Select Year to Generate Calendar"
GoTo ResetApplication
Exit Sub
End If
'clear first 7 columns and any previous calendar:
ws.Range("A:G").Clear
D = 0
'set names of 12 months for the array monthName:
monthName(1) = "January"
monthName(2) = "February"
monthName(3) = "March"
monthName(4) = "April"
monthName(5) = "May"
monthName(6) = "June"
monthName(7) = "July"
monthName(8) = "August"
monthName(9) = "September"
monthName(10) = "October"
monthName(11) = "November"
monthName(12) = "December"
'set names of 7 week days for the array weekDay:
weekDay(1) = "Monday"
weekDay(2) = "Tuesday"
weekDay(3) = "Wednesday"
weekDay(4) = "Thursday"
weekDay(5) = "Friday"
weekDay(6) = "Saturday"
weekDay(7) = "Sunday"
For mth = 1 To 12
'for each of the 12 months in a year
counter = 1
'determine day 1 for each month:
If mth = 1 Then
dateDay1 = "1/1/" & calYearCell
wkDay = Application.Text(dateDay1, "dddd")
If wkDay = "Monday" Then
firstDay = 1
ElseIf wkDay = "Tuesday" Then
firstDay = 2
ElseIf wkDay = "Wednesday" Then
firstDay = 3
ElseIf wkDay = "Thursday" Then
firstDay = 4
ElseIf wkDay = "Friday" Then
firstDay = 5
ElseIf wkDay = "Saturday" Then
firstDay = 6
ElseIf wkDay = "Sunday" Then
firstDay = 7
End If
Else
firstDay = firstDay
End If
'determine number of days in each month and the leap year:
dateLeapYear = "2/1/" & calYearCell
M = month(dateLeapYear)
Y = Year(dateLeapYear)
Days = DateSerial(Y, M + 1, 1) - DateSerial(Y, M, 1)
If mth = 1 Or mth = 3 Or mth = 5 Or mth = 7 Or mth = 8 Or mth = 10 Or mth = 12 Then
mthDays = 31
ElseIf mth = 2 Then
If Days = 28 Then
mthDays = 28
ElseIf Days = 29 Then
mthDays = 29
End If`Else
mthDays = 30
End If
`
'determine last used row:
If mth = 1 Then
iRow = 0
Else
iRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
End If
dt = 1
'maximum of 6 rows to accomodate all days of a month:
For i = 1 To 6
'7 columns for each week day of Monday to Sunday:
For b = 1 To 7
'enter name of the month:
ws.Cells(iRow + 1, 1) = monthName(mth)
ws.Cells(iRow + 1, 1).Font.Color = RGB(0, 0, 200)
ws.Cells(iRow + 1, 1).Font.Bold = True
ws.Range("A" & iRow + 1 & ":G" & iRow + 1).Interior.Color = RGB(191, 191, 191)
ws.Range("A" & iRow + 1 & ":G" & iRow + 1).Borders(xlEdgeTop).LineStyle = XlLineStyle.xlContinuous
'enter week day (Monday, Tuesday, ...):
ws.Cells(iRow + 2, b) = weekDay(b)
ws.Range("A" & iRow + 2 & ":G" & iRow + 2).Font.Bold = True
ws.Range("A" & iRow + 2 & ":G" & iRow + 2).Interior.Color = RGB(0, 5000, 0)
ws.Range("F" & iRow + 2 & ":G" & iRow + 2).Interior.Color = RGB(5000, 0, 0)
'enter each date in a month:
If dt <= mthDays Then
'dates placement for the first row (for each month):
If firstDay > 1 And counter = 1 Then
For x = 1 To 8 - firstDay
ws.Cells(iRow + 2 + i, firstDay + x - 1) = x
Next x
dt = 9 - firstDay
'after placement of dates in the first-row for a month the counter value changes to 2, and then reverts
to 1 for the next month cycle:
counter = 2
w = 1
End If
'dates placement after the first row (for each month):
ws.Cells(iRow + 2 + i + w, b) = dt
dt = dt + 1
End If
Next b
Next i
w = 0
'determine placement of day 1 for each month after the first month:
firstDay = firstDay + mthDays Mod 7
If firstDay > 7 Then
firstDay = firstDay Mod 7
Else
firstDay = firstDay
End If
Next mth
'formatting:
iRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
ws.Range("A" & iRow & ":G" & iRow).Borders(xlEdgeBottom).LineStyle = XlLineStyle.xlContinuous
ws.Range("G1:G" & iRow).Borders(xlEdgeRight).LineStyle = XlLineStyle.xlContinuous
With ws.Range("A1:G" & iRow)
.Font.Name = "Arial"
.Font.Size = 9
.RowHeight = 12.75
.HorizontalAlignment = xlCenter
.ColumnWidth = 9
End With
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
ResetApplication:
Err.Clear
On Error GoTo 0
Application.EnableEvents = True
End Sub
' for floating holidays
Public Sub floatingholidays(NDow As Date, Y As Integer, M As Integer, _
N As Integer, DOW As Integer)
NDow = DateSerial(Y, M, (8 - weekDay(DateSerial(Y, M, 1), _
(DOW + 1) Mod 8)) + ((N - 1) * 7))
End Sub
'for Easter date determination
Public Sub EasterDate(EasterDate2 As Date, Yr As Integer)
Dim D As Integer
D = (((255 - 11 * (Yr Mod 19)) - 21) Mod 30) + 21
EasterDate2 = DateSerial(Yr, 3, 1) + D + (D > 48) + 6 - ((Yr + Yr \ 4 + _
D + (D > 48) + 1) Mod 7)
End Sub