excel
在政府网站查询最新的《国务院办公厅关于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
复制通知内容，保存为'节假日安排通知.txt'
在上述文本文件位置新建一个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
运行此宏，得到如下结果。