根据节假日安排通知用宏自动生成工作日年历

1、在政府网站查询最新的《国务院办公厅关于XXXX年部分节假日安排的通知》

http://search.www.gov.cn/search/fw/cateSearch.do?webid=1&p=1&category=zcwj&criteria_adapter=&gwy=&q=%E8%8A%82%E5%81%87%E6%97%A5%E5%AE%89%E6%8E%92

2、复制通知内容，保存为"节假日安排通知.txt"

3、在上述文本文件位置新建一个EXCEL文件，插入以下宏。

Sub 节假日生成()    exph = ThisWorkbook.Path    Set wshshell = CreateObject("WScript.Shell")    Set fso = CreateObject("Scripting.FileSystemObject")    If Not fso.fileexists(exph & "\节假日通知.txt") Then        Set fso = Nothing        Set wshshell = Nothing        MsgBox "未找到文件：节假日通知.txt，将退出运行！"        Exit Sub    End If    Set theFile = fso.OpenTextFile(exph & "\节假日通知.txt", 1, True)    jjrtz = theFile.ReadAll    theFile.Close    Set fso = Nothing    Set wshshell = Nothing    findstr = ""    replacestr = ""    With CreateObject("VBScript.Regexp")        .Global = True: .MultiLine = True        .Pattern = "国务院办公厅关于\d{4}年"        For Each RegMatch In .Execute(jjrtz)            findstr = RegMatch.Value            Exit For        Next    End With    With CreateObject("VBScript.Regexp")        .Global = True: .MultiLine = True        .Pattern = "国务院办公厅关于"        replacestr = .Replace(findstr, "")        .Pattern = "年"        replacestr = .Replace(replacestr, "")    End With    If Len(replacestr) <> 0 Then        nf = replacestr        nf_before = nf - 1        Sheets(1).Name = nf    Else        MsgBox "未找到通知年份，将退出运行！"        Exit Sub    End If    Sheets(1).Columns("A:E").ClearContents    Sheets(1).Range("A1").Value = "节日"    Sheets(1).Range("b1").Value = "放假日"    Sheets(1).Range("c1").Value = "双休上班"    Sheets(1).Range("d1").Value = "年历日期"    Sheets(1).Range("e1").Value = "日期属性"        kk = 0    ReDim List(kk)    findstr = ""    With CreateObject("VBScript.Regexp")        .Global = True: .MultiLine = True        .Pattern = "^\S+、\S+：\S+。$"        For Each RegMatch In .Execute(jjrtz)            kk = kk + 1            ReDim Preserve List(kk)            List(kk) = RegMatch.Value        Next    End With    ii = 0    pp = 0    oo = 0    qq = 0    rr = 0    ReDim jrList(pp)    ReDim tslist(qq)    ReDim fjrList(oo)    ReDim pxList(rr)    sbhs = 2    Do Until ii = kk        ii = ii + 1                        findstr = ""        replacestr = ""        With CreateObject("VBScript.Regexp")            .Global = True: .MultiLine = True            .Pattern = "^[^，。、]+、[^，。]+："            For Each RegMatch In .Execute(List(ii))                findstr = RegMatch.Value                Exit For            Next        End With        With CreateObject("VBScript.Regexp")            .Global = True: .MultiLine = True            .Pattern = "^[^，。、]+、"            replacestr = .Replace(findstr, "")            .Pattern = "："            replacestr = .Replace(replacestr, "")        End With        If Len(replacestr) <> 0 Then            pp = pp + 1            ReDim Preserve jrList(pp)            jrList(pp) = replacestr        Else            MsgBox "未找到具体节日，将退出运行！"            Exit Sub        End If            findstr = ""        replacestr = ""        With CreateObject("VBScript.Regexp")            .Global = True: .MultiLine = True            .Pattern = "放假(调休)*，共\d{1}天。"            For Each RegMatch In .Execute(List(ii))                findstr = RegMatch.Value                Exit For            Next        End With        With CreateObject("VBScript.Regexp")            .Global = True: .MultiLine = True            .Pattern = "放假(调休)*，共"            replacestr = .Replace(findstr, "")            .Pattern = "天。"            replacestr = .Replace(replacestr, "")        End With        qq = qq + 1        If Len(replacestr) <> 0 Then            ReDim Preserve tslist(qq)            tslist(qq) = replacestr        Else            ReDim Preserve tslist(qq)            tslist(qq) = 1        End If                findstr = ""        replacestr = ""        With CreateObject("VBScript.Regexp")            .Global = True: .MultiLine = True            .Pattern = "：(\d+年)*\d+月[^，。：]+放假"            For Each RegMatch In .Execute(List(ii))                findstr = RegMatch.Value                Exit For            Next        End With        With CreateObject("VBScript.Regexp")            .Global = True: .MultiLine = True            .Pattern = "放假"            replacestr = .Replace(findstr, "")            .Pattern = "：(\d+年)*"            replacestr = .Replace(replacestr, "")            .Pattern = "[至—]{1}\S+"            replacestr = .Replace(replacestr, "")        End With        If Len(replacestr) <> 0 Then            oo = oo + 1            ReDim Preserve fjrList(oo)            fjrList(oo) = replacestr        Else            MsgBox "未找到" & jrList(pp) & "具体放假日，将退出运行！"            Exit Sub        End If                findstr = ""        replacestr = ""        With CreateObject("VBScript.Regexp")            .Global = True: .MultiLine = True            .Pattern = "，(\d+年)*\d+月[^，。：]+补休"            For Each RegMatch In .Execute(List(ii))                findstr = RegMatch.Value                Exit For            Next        End With        With CreateObject("VBScript.Regexp")            .Global = True: .MultiLine = True            .Pattern = "，(\d+年)*"            replacestr = .Replace(findstr, "")            .Pattern = "[（(]{1}\S+[）)]{1}补休"            replacestr = .Replace(replacestr, "")        End With        rr = rr + 1        If Len(replacestr) <> 0 Then            ReDim Preserve pxList(rr)            pxList(ii) = replacestr            tslist(qq) = tslist(qq) + 1        Else            ReDim Preserve pxList(rr)        End If                   findstr = ""        replacestr = ""        With CreateObject("VBScript.Regexp")            .Global = True: .MultiLine = True            .Pattern = "[，。]{1}(\d+年)*\d+月[^，。]+上班"            For Each RegMatch In .Execute(List(ii))                findstr = RegMatch.Value            Next        End With        With CreateObject("VBScript.Regexp")            .Global = True: .MultiLine = True            .Pattern = "[，。]{1}(\d+年)*"            replacestr = .Replace(findstr, "")            .Pattern = "上班"            replacestr = .Replace(replacestr, "")        End With        sbxrhs = sbhs        If Len(replacestr) <> 0 Then            sbr = replacestr            findstr = ""            aa = Split(sbr, "、")   '以 、  为分割，把保存为数组a                    findstr1 = ""                    replacestr1 = ""                    For Each subt In aa                        replacestr = ""                        With CreateObject("VBScript.Regexp")                            .Global = True: .MultiLine = True                            .Pattern = "[（(]{1}\S+[）)]{1}"                            replacestr = .Replace(subt, "")                        End With                                                With CreateObject("VBScript.Regexp")                            .Global = True: .MultiLine = True                            .Pattern = "\d+月"                            For Each RegMatch In .Execute(replacestr)                                findstr1 = RegMatch.Value                                Exit For                            Next                        End With                        If Len(replacestr) < 4 Then                            replacestr = findstr1 & replacestr                        End If                                                                                If Len(replacestr) <> 0 Then                            If InStr(replacestr, "12月") <> 0 And ii = 1 Then                                Sheets(1).Range("c" & sbxrhs).Value = replacestr & nf_before & "年"                            Else                                Sheets(1).Range("c" & sbxrhs).Value = replacestr & nf & "年"                            End If                            sbxrhs = sbxrhs + 1                        End If                    Next        End If        sbhs = sbhs + tslist(ii)    Loop    i = 1    jrhs = 2    Do Until i > qq        Sheets(1).Range("A" & jrhs).Value = jrList(i)        If InStr(fjrList(i), "12月") <> 0 And i = 1 Then            Sheets(1).Range("b" & jrhs).Value = fjrList(i) & nf_before & "年"        Else            Sheets(1).Range("b" & jrhs).Value = fjrList(i) & nf & "年"        End If        If tslist(i) = 2 Then           If InStr(pxList(i), "12月") <> 0 And i = 1 Then               Sheets(1).Range("b" & jrhs + 1).Value = pxList(i) & nf_before & "年"           Else               Sheets(1).Range("b" & jrhs + 1).Value = pxList(i) & nf & "年"           End If        End If        If tslist(i) > 2 Then            Sheets(1).Range("B" & jrhs).AutoFill Destination:=Range("B" & jrhs & ":B" & jrhs + tslist(i) - 1), Type:=xlFillDefault        End If        jrhs = jrhs + tslist(i)        i = i + 1    Loop    Sheets(1).Range("d2").FormulaR1C1 = "=MIN(RC[-2],RC[-1])"    Sheets(1).Range("d2").Copy    Sheets(1).Range("d2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Application.CutCopyMode = False    Sheets(1).Range("f2").FormulaR1C1 = "1/1/" & nf + 1    Sheets(1).Range("g2").FormulaR1C1 = "=RC[-1]-RC[-3]"    xsts = Sheets(1).Range("g2").Value    Sheets(1).Range("F2:G2").ClearContents    Sheets(1).Range("d2").AutoFill Destination:=Range("d2:d" & xsts + 1), Type:=xlFillDefault    Sheets(1).Range("E2").FormulaR1C1 = _        "=IF(COUNTIF(C[-3],RC[-1])=1,""节假日"",IF(WEEKDAY(RC[-1],2)>=6,IF(COUNTIF(C[-2],RC[-1])<>1,""节假日"",""工作日""),""工作日""))"    Sheets(1).Range("e2").AutoFill Destination:=Range("e2:e" & xsts + 1), Type:=xlFillDefault    Sheets(1).Columns("D:D").FormatConditions.Delete    Sheets(1).Columns("D:D").FormatConditions.Add Type:=xlExpression, Formula1:= _        "=OR(AND(WEEKDAY(RC,2)<6,COUNTIF(C[-2],RC)=1),COUNTIF(C[-1],RC)=1)"    Sheets(1).Columns("D:D").FormatConditions(Sheets(1).Columns("D:D").FormatConditions.Count).SetFirstPriority    With Sheets(1).Columns("D:D").FormatConditions(1).Interior        .PatternColorIndex = xlAutomatic        .Color = 65535        .TintAndShade = 0    End With    Sheets(1).Columns("D:D").FormatConditions(1).StopIfTrue = False    Sheets(1).Columns("B:D").NumberFormatLocal = "yyyy/m/d"End Sub

4、运行此宏，得到如下结果。