- 帖子
- 1425
- 主題
- 40
- 精華
- 0
- 積分
- 1449
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-4-16
|
本帖最後由 Andy2483 於 2022-12-7 11:34 編輯
回復 3# 星空乂羽翼
謝謝前輩回復!請試試看
後學藉此題練習陣列與字典,學到很多知識,謝謝
1.下載檔案
行政院人事總處官網:
https://www.dgpa.gov.tw
112年辦公日曆表.xls下載:
https://www.dgpa.gov.tw/FileConversion?filename=dgpa/files/202206/e71dbdb7-5339-48a7-b11e-172b2875df1e.xls&nfix=&name=112%E5%B9%B4%E8%BE%A6%E5%85%AC%E6%97%A5%E6%9B%86%E8%A1%A8.xls
2.將下列程式碼放入VBA作執行
下載檔案,未執行:
執行後:
Option Explicit
Sub 上班日_假日_補班日()
Dim Brr, Sh1, V, xA, xR, Z, P, W, i&, n&, Ch$, y%, ymd As Date
Dim X&(4)
Set W = CreateObject("Scripting.Dictionary")
Set Z = CreateObject("Scripting.Dictionary")
Set P = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("Sheet1")
Set Brr = Range(Sh1.[A1], Sh1.UsedRange)
Sh1.[AA:AH].ClearContents
V = Split(",一,二,三,四,五,六,七,八,九,十,十一,十二", ",")
For i = 1 To 12
Z(V(i) & "月") = i
Next
For Each xR In Brr
If xR Like "*西元####年*" Then y = Mid(xR, InStr(xR, "西元") + 2, 4)
Ch = xR & xR.Item(, 2) & xR.Item(, 3)
If Z.Exists(Ch) And xR.Item(, 3) <> "" Then
Set W(Ch) = xR.Item(1, -1).Resize(14, 7)
End If
Next
Z.Add "非周休二日假日", 1
Z.Add "周休二日", 3
Z.Add "上班日", 5
Z.Add "補班日", 7
For Each xR In W.KEYS
For Each xA In W(xR)
If IsNumeric(xA) And xA <> "" Then
ymd = y & "/" & Z(xR) & "/" & xA
If xA.Interior.ColorIndex <> -4142 Then
If Format(ymd, "w") > 1 And Format(ymd, "w") < 7 Then
P(ymd) = "非周休二日假日"
X(1) = X(1) + 1
W(ymd) = X(1)
Else
P(ymd) = "周休二日"
X(2) = X(2) + 1
W(ymd) = X(2)
End If
ElseIf Format(ymd, "w") > 1 And Format(ymd, "w") < 7 Then
P(ymd) = "上班日"
X(3) = X(3) + 1
W(ymd) = X(3)
n = n + 1
Else
P(ymd) = "補班日"
X(4) = X(4) + 1
W(ymd) = X(4)
End If
End If
Next
Next
ReDim Brr(1 To n, 1 To 8)
For Each xR In P.KEYS
ymd = xR
Brr(W(ymd), Z(P(ymd))) = ymd
Brr(W(ymd), Z(P(ymd)) + 1) = Format(ymd, "aaaa")
Next
[AA1].Resize(1, 8) = [{"非周休二日假日","","周休二日","","上班日","","補班日",""}]
[AA2].Resize(n, 8) = Brr
Sh1.[AA:AH].Columns.AutoFit
[AA1].CurrentRegion.Borders.LineStyle = 1
Set W = Nothing: Set Z = Nothing: Set P = Nothing: Set Brr = Nothing
Erase V, X
End Sub |
|
發表於 2022-12-7 11:27
| 
