- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
3#
發表於 2018-1-8 21:37
| 只看該作者
本帖最後由 GBKEE 於 2018-1-8 21:40 編輯
回復 2# av8d
參考看看- Option Explicit
- Sub Ex()
- Dim i As Integer, 輪值表(), x As Integer
- Dim xDay As Date, xWeek()
- Xy:
- On Error Resume Next
- xDay = DateSerial(InputBox("輸入年份", , Year(Date)), 1, 1)
- If Err > 0 Then
- If MsgBox("年份??? : 重新輸入? ", vbOKCancel) = vbCancel Then
- Exit Sub
- Else
- GoTo Xy
- End If
- End If
- On Error GoTo 0
- xWeek = Array("星期日", "星期一", "星期二", "星期三", "星期四", "星期五", "星期六")
- With Sheets("輪值人員表")
- 輪值表 = .Range("B1", .Range("B1").End(xlDown).Address).Value
- 輪值表 = Application.WorksheetFunction.Transpose(輪值表)
- End With
-
- With Cells
- .Clear
- .Range("B1") = Year(xDay) & "年"
- .Range("B2") = "輪值人員"
- .HorizontalAlignment = xlCenter
- .Font.Size = 22
- End With
- i = 1
- Do
- With Range("c" & i).Resize(, 7)
- .Cells(1) = Month(xDay)
- .Merge
- .NumberFormatLocal = "0""月""""份"""
- .Offset(1).Resize(, 7) = xWeek
- End With
- i = i + 2
- Do
- Cells(i, "C").Cells(1, Weekday(xDay, vbSunday)).Cells = Day(xDay)
- With Cells(i, "B")
- If .Cells = "" Then
- x = Application.WorksheetFunction.WeekNum(xDay)
- If x < UBound(輪值表) Then
- .Cells = 輪值表(x)
- Else
- If x Mod UBound(輪值表) = 0 Then
- .Cells = 輪值表(1)
- Else
- .Cells = 輪值表(x Mod UBound(輪值表) + 1)
- End If
- End If
- End If
- End With
- If Cells(i, "B") = "" Then Application.WorksheetFunction.WeekNum (xDay)
- If Weekday(xDay, vbSunday) = 7 And Month(xDay) = Month(xDay + 1) Then i = i + 1
- xDay = xDay + 1
- Loop Until Month(xDay) <> Month(xDay - 1)
- i = i + 1
- Loop Until Year(xDay) <> Year(xDay - 1)
- End Sub
複製代碼 |
|