麻辣家族討論版版 - Powered by Discuz! Board

Sub 簡易橫式年曆()
Dim yy As Integer, mm As Integer, dd As Integer, d2 As Integer, w As Integer
yy = 2016
[B2:AF47] = ""
[B2:AF47].Interior.ColorIndex = xlNone
For mm = 1 To 12
d2 = Day(DateSerial(yy, mm + 1, 0))
For dd = 1 To d2
Cells(mm * 4 - 1, dd + 1) = DateSerial(yy, mm, dd)
w = Weekday(Cells(mm * 4 - 1, dd + 1), vbSunday)
Cells(mm * 4 - 2, dd + 1).NumberFormatLocal = "d"
Cells(mm * 4 - 2, dd + 1).FormulaR1C1 = "=RIGHT(TEXT(R[1]C,""aaa""))"
If w = 1 Then
Cells(mm * 4 - 2, dd + 1).Font.ColorIndex = 3
ElseIf w = 7 Then
Cells(mm * 4 - 2, dd + 1).Font.ColorIndex = 5
Else
Cells(mm * 4 - 2, dd + 1).Font.ColorIndex = 1
End If
Next
Next
End Sub
Sub 漆後資訊()
Dim shA As Worksheet
Dim LstR As Integer, I As Integer, J As Integer, eDay As Integer, mNUM As Integer
Dim Rng As Range, SD As Range, ED As Range, Scel As Range, Ecel As Range
Set shA = Sheets("A")
Set Rng = [B3:AF47]
Rng.Interior.ColorIndex = xlNone
LstR = shA.[M4].End(xlDown).Row
For I = 4 To LstR
Set SD = shA.Cells(I, 13) 'Start Date
Set ED = shA.Cells(I, 14) 'End Date
If SD.Value > ED.Value Then
MsgBox "起始日期：" & SD.Value & " > 終止日期：" & ED.Value & ", 請查明再繼續!!", vbOKOnly
Exit For
End If
Set Scel = Rng.Find(SD, Lookat:=xlWhole) '在年曆中尋找 Start Date
If Scel Is Nothing Then
MsgBox "查無此日期:" & SD & ", 請查明再繼續!!", vbOKOnly
Exit For
End If
Set Ecel = Rng.Find(ED, Lookat:=xlWhole) '在年曆中尋找 End Date
If Ecel Is Nothing Then
MsgBox "查無此日期:" & ED & ", 請查明再繼續!!", vbOKOnly
Exit For
End If
If Scel.Row = Ecel.Row Then '同一月
Scel.Resize(1, Ecel.Column - Scel.Column + 1).Interior.ColorIndex = 6
ElseIf Ecel.Row - Scel.Row >= 4 Then '跨前後月
eDay = Day(DateSerial(Year(Scel), Month(Scel) + 1, 0))
Scel.Resize(1, eDay - Scel.Column + 2).Interior.ColorIndex = 6
Cells(Ecel.Row, "B").Resize(1, Ecel.Column - 1).Interior.ColorIndex = 6
If Ecel.Row - Scel.Row > 4 Then '跨兩三月
For J = Scel.Row + 4 To Ecel.Row - 4 Step 4
Cells(J, "B").Resize(1, Cells(J, "B").End(xlToRight).Column - 1).Interior.ColorIndex = 6
Next
End If
End If
Next
End Sub

複製代碼