- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
5#
發表於 2014-2-7 14:17
| 只看該作者
本帖最後由 GBKEE 於 2014-2-7 17:39 編輯
回復 4# j88141
試試看- Option Explicit
- Private Sub Workbook_Open() 'ThisWorkbook 模組的程式碼,開檔時自動執行
- Dim xWeek, xM, Rng(0 To 2) As Range, i As Integer, ii As Integer
- For Each xM In ActiveWorkbook.Names
- xM.Delete
- Next
- xWeek = Split("星期一,星期二,星期三,星期四,星期五", ",")
- xM = Split("早上,下午,晚上", ",")
-
- With Sheets("課表雛形")
- Set Rng(0) = .Range("D3:D18") '早上時段 '如有不對請自行修改
- Set Rng(1) = .Range("D19:D34") '下午時段
- Set Rng(2) = .Range("D35:D42") '晚上時段
- For i = 0 To 4
- For ii = 0 To 2
- Rng(ii).Offset(, i).Name = xWeek(i) & xM(ii)
- Next
- Next
- End With
- End Sub
複製代碼 "課表雛形" 工作表模組的程式碼- Option Explicit Private
- Sub Worksheet_Change(ByVal Target As Range)
- Application.EnableEvents = False
- If 時段(Target) Then Target = ""
- Application.EnableEvents = True
- End Sub
- Private Function 時段(xRng As Range) As Boolean '傳回 False 成為 0 ,而 True 成為 -1
- Dim xR As String, N As Name, C As CheckBox
- For Each N In ActiveWorkbook.Names
- If Not Application.Intersect(Range(N), xRng) Is Nothing Then
- xR = N.Name '取得 星期上下晚的時段
- Exit For
- End If
- Next
- With Sheets("老師不排課時段")
- For Each C In .CheckBoxes
- If .Cells(C.TopLeftCell.Row, 1) = xRng And C = 1 Then
- If xR = .Cells(1, C.TopLeftCell.Column).MergeArea.Cells(1) & C.TopLeftCell.End(xlUp) Then
- '星期的時段 .Cells(1, C.TopLeftCell.Column).MergeArea.Cells(1)
- '上下晚的時段 C.TopLeftCell.End(xlUp)
- 時段 = True
- MsgBox xRng & vbLf & xR & vbLf & "不排課程"
- Exit For
- End If
- End If
- Next
- End With
- End Function
複製代碼 |
|