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

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 S髫潋啜缅et 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、运行此宏，得到如下结果。