EXCEL國定假日自動更新

星空乂羽翼

請問各位大前輩
目前小弟有做ㄧ些萬年曆或是專案的檔案
目前國定假日或補班日的日期都是在分頁上用手動的方式打上

請問有沒有什麼方式可以讓每年的國定假日及補班日可以自動抓取資料呢？
我自己想到可能的方式如像股票那樣用網頁抓取資料的方式
但還不確定可行性

再麻煩各位大大幫忙，感謝！

Andy2483

回復 1# 星空乂羽翼


    謝謝前輩發表此主題
論壇有對網頁抓取很厲害的前輩!
如果上傳範例檔(萬年曆或是專案的檔案)與告知想要用哪個行事曆網頁網址做更新,
比較有機會有方案可解決

星空乂羽翼

回復 2# Andy2483
感謝Andy2483前輩回覆
檔案如附件
人員記錄表 測試 20221206.rar (14.78 KB)

下載次數: 7

2022-12-6 13:16

目前表單是製作萬年歷的樣式
用來記錄每日中餐人員數量
但只要新的ㄧ年就要自己用手動更新補班日及休假日
想依照行政院公告行事曆的補班日及休假日進行更新
不知道是否可行呢？

p.s小弟權限不足，無法貼網址，要麻煩各位大大查一下政院公告行事曆，不好意思

Andy2483

回復 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作執行

下載檔案,未執行:

下載 (256.89 KB)

2022-12-7 11:26

執行後:

下載 (591.13 KB)

2022-12-7 11:27

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

Andy2483

添加簡單防錯:

下載 (358.02 KB)

2022-12-7 12:45

Option Explicit
Sub 上班日_假日_補班日()
Dim Brr, Sh1, V, xA, xR, Z, P, W, i&, n&, Ch$, y%, ymd As Date
Dim X&(4), T&
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
For ymd = y & "/1/1" To y & "/12/31"
   If P.Exists(ymd) = Empty Then
      MsgBox "缺少: " & ymd
      GoTo 111
   End If
   T = T + 1
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
MsgBox y & "年 共有 " & T & " 天" & vbLf & _
       "非周休二日假日 共: " & X(1) & " 天" & vbLf & _
       "周休二日 共: " & X(2) & " 天" & vbLf & _
       "上班日 共: " & X(3) & " 天" & vbLf & _
       "補班日 共: " & X(4) & " 天"

111
Set W = Nothing: Set Z = Nothing: Set P = Nothing: Set Brr = Nothing
Erase V, X
End Sub

星空乂羽翼

回復 4# Andy2483

感謝Andy2483前輩的回覆
測試完成可以正常使用，謝謝。

另外想請問可以自動抓取網頁檔案嗎?
還是ㄧ定要手動自己下載呢?

星空乂羽翼

回復 5# Andy2483

感謝Andy2483前輩的回覆
請問此貼文與上一篇
除了增加顯示天數以外
還有新增或修改什麼內容嗎？

Andy2483

回復 6# 星空乂羽翼


    謝謝前輩回復
1.前輩要行政院的行事曆!查行政院人事總處官網只查到附件或行事曆圖片!沒查到以網頁文字呈現的行事曆,等看前輩們的其他方案
2.這更新行事曆的作業,一年更新一次,有什麼特別的需要嗎?需要每天都再檢查一次?
3.如果有網頁是以文字表格呈現的行事曆,應該有機會符合前輩的需求
4.後學也想以網頁更新的 VBA 知識

Andy2483

回復 7# 星空乂羽翼


    除了增加顯示天數以外,執行的結果沒有不同,簡單檢查資料表因編輯而漏掉的日期
密防難!使用者謹慎為之!

星空乂羽翼

回復 8# Andy2483

感謝Andy2483前輩的回覆
了解
我主要也是想了解以網頁更新VBA這部分。
還是非常感謝您的解答！