【案例】批量制作议题审批单

Sub 处理会议议程()

    Dim 领导议程数组 As Variant
    文档内容 = ThisDocument.Content.Text

    ' 【创建正则表达式对象，并执行匹配】
    Set 正则表达式对象 = CreateObject("VBScript.RegExp")
    议程模式 = "([一二三四五六七八九十]+、[\s\S]*?会议议定：[\s\S]*?。$)|(（[一二三四五六七八九十]+）[\s\S]*?会议议定：[\s\S]*?。$)"
    正则表达式对象.Pattern = 议程模式
    正则表达式对象.Global = True
    正则表达式对象.MultiLine = True
    Set 匹配结果 = 正则表达式对象.Execute(文档内容)

    ' 【创建字典存储领导和对应的议题数组】
    Set 领导字典 = CreateObject("Scripting.Dictionary")

    For Each 单个匹配 In 匹配结果
        议程文本 = 单个匹配.Value
        领导姓名 = InputBox(Title:="下面议题由哪个领导分管？", prompt:=议程文本)
        
        If 领导字典.Exists(领导姓名) Then
            领导议程数组 = 领导字典(领导姓名)
            ReDim Preserve 领导议程数组(UBound(领导议程数组) + 1)
            领导议程数组(UBound(领导议程数组)) = 议程文本
            领导字典(领导姓名) = 领导议程数组
        Else
            ReDim 领导议程数组(0)
            领导议程数组(0) = 议程文本
            领导字典.Add 领导姓名, 领导议程数组
        End If
    Next

    ' 【为每个领导创建一个文档并写入议题】
    第几次 = InputBox(Title:="获取期数", prompt:="本次召开的是2025年第几次院长办公会？(输入阿拉伯数字)")
    开会日期 = InputBox(Title:="获取开会日期", prompt:="本次会议的召开时间？(参照格式：2025年8月20日上午)")
    
    For Each 领导姓名 In 领导字典.Keys
        Set 新文档 = Documents.Add
        新文档.Range(0, 0).Text = "2025年第" & 第几次 & "次院长办公会纪要审签单" & vbCrLf & vbCrLf
        新文档.Content.InsertAfter 领导姓名 & "：" & vbCrLf
        新文档.Content.InsertAfter 开会日期 & "，党委副书记、副院长（主持行政工作）杨绿主持召开2025年第" & 第几次 & "次院长办公会，现将您所分管的议题内容作如下纪要：" & vbCrLf
        
        
        领导议程数组 = 领导字典(领导姓名)
        For i = LBound(领导议程数组) To UBound(领导议程数组)
            新文档.Content.InsertAfter 领导议程数组(i) & vbCrLf
        Next
        新文档.Content.InsertAfter vbCrLf & "针对以上纪要内容，请您审签意见："
        
        For i = 1 To 新文档.Paragraphs.Count
            If i = 1 Then
                新文档.Paragraphs(i).Alignment = wdAlignParagraphCenter
                新文档.Paragraphs(i).Range.Font.Name = "方正小标宋简体"
                新文档.Paragraphs(i).Range.Font.Size = 22
            End If
            If i >= 4 Then
                新文档.Paragraphs(i).FirstLineIndent = 32    '仿宋gb2312字体，对应的2个字符宽度为32磅
            End If
        Next
               
        新文档.SaveAs2 FileName:=领导姓名 & ".docx"
        新文档.Close
    Next
End Sub