返回列表 上一主題 發帖

[發問] 儲存格規則問題

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
1# 跳轉到 »
發表於 2015-12-24 09:19 | 顯示全部帖子
試試VBA:
  1. Sub 簡易橫式年曆()
  2.     Dim yy As Integer, mm As Integer, dd As Integer, d2 As Integer, w As Integer
  3.     yy = 2016
  4.     [B2:AF47] = ""
  5.     [B2:AF47].Interior.ColorIndex = xlNone
  6.     For mm = 1 To 12
  7.         d2 = Day(DateSerial(yy, mm + 1, 0))
  8.         For dd = 1 To d2
  9.             Cells(mm * 4 - 1, dd + 1) = DateSerial(yy, mm, dd)
  10.             w = Weekday(Cells(mm * 4 - 1, dd + 1), vbSunday)
  11.             Cells(mm * 4 - 2, dd + 1).NumberFormatLocal = "d"
  12.             Cells(mm * 4 - 2, dd + 1).FormulaR1C1 = "=RIGHT(TEXT(R[1]C,""aaa""))"
  13.             If w = 1 Then
  14.                 Cells(mm * 4 - 2, dd + 1).Font.ColorIndex = 3
  15.             ElseIf w = 7 Then
  16.                 Cells(mm * 4 - 2, dd + 1).Font.ColorIndex = 5
  17.             Else
  18.                 Cells(mm * 4 - 2, dd + 1).Font.ColorIndex = 1
  19.             End If
  20.         Next
  21.     Next
  22. End Sub

  24. Sub 漆後資訊()
  25.     Dim shA As Worksheet
  26.     Dim LstR As Integer, I As Integer, J As Integer, eDay As Integer, mNUM As Integer
  27.     Dim Rng As Range, SD As Range, ED As Range, Scel As Range, Ecel As Range
  28.     Set shA = Sheets("A")
  29.     Set Rng = [B3:AF47]
  30.     Rng.Interior.ColorIndex = xlNone
  31.     LstR = shA.[M4].End(xlDown).Row
  32.     For I = 4 To LstR
  33.         Set SD = shA.Cells(I, 13)     'Start Date
  34.         Set ED = shA.Cells(I, 14)     'End Date
  35.         If SD.Value > ED.Value Then
  36.             MsgBox "起始日期：" & SD.Value & " > 終止日期：" & ED.Value & ", 請查明再繼續!!", vbOKOnly
  37.             Exit For
  38.         End If
  39.         Set Scel = Rng.Find(SD, Lookat:=xlWhole)       '在年曆中尋找 Start Date
  40.         If Scel Is Nothing Then
  41.             MsgBox "查無此日期:" & SD & ", 請查明再繼續!!", vbOKOnly
  42.             Exit For
  43.         End If
  44.         Set Ecel = Rng.Find(ED, Lookat:=xlWhole)       '在年曆中尋找 End Date
  45.         If Ecel Is Nothing Then
  46.             MsgBox "查無此日期:" & ED & ", 請查明再繼續!!", vbOKOnly
  47.             Exit For
  48.         End If
  49.         
  50.         If Scel.Row = Ecel.Row Then    '同一月
  51.             Scel.Resize(1, Ecel.Column - Scel.Column + 1).Interior.ColorIndex = 6
  52.         ElseIf Ecel.Row - Scel.Row >= 4 Then    '跨前後月
  53.             eDay = Day(DateSerial(Year(Scel), Month(Scel) + 1, 0))
  54.             Scel.Resize(1, eDay - Scel.Column + 2).Interior.ColorIndex = 6
  55.             Cells(Ecel.Row, "B").Resize(1, Ecel.Column - 1).Interior.ColorIndex = 6
  56.             If Ecel.Row - Scel.Row > 4 Then     '跨兩三月
  57.                 For J = Scel.Row + 4 To Ecel.Row - 4 Step 4
  58.                     Cells(J, "B").Resize(1, Cells(J, "B").End(xlToRight).Column - 1).Interior.ColorIndex = 6
  59.                 Next
  60.             End If
  61.         End If
  62.     Next
  63. End Sub
複製代碼
test.gif

TOP

        靜思自在 : 甘願做、歡喜受。
返回列表 上一主題