请求修改VBA代码：遍历数据验证列表批量生成Word文档

核心修改思路 #

1. 提取合并单元格B9:C9的数据验证数据源，遍历每个条目
2. 循环中更新B9:C9的选中值，确保Excel表格对应数据同步更新
3. 为每个条目生成独立Word文档并自动保存
4. 优化Word对象的创建与释放逻辑，避免内存残留

修改后的完整VBA代码 #

Sub BatchExportToWord()
    Dim ws As Worksheet
    Dim tbl As Range
    Dim wordApp As Object
    Dim wordDoc As Object
    Dim wordTable As Object
    Dim dvSource As String
    Dim sourceCells As Variant
    Dim cellAddr As Variant
    Dim dvItem As String
    Dim savePath As String
    
    ' 初始化工作表和表格区域
    Set ws = ThisWorkbook.Sheets("Export Objectives to Word")
    Set tbl = ws.Range("B7:C29")
    savePath = ThisWorkbook.Path & "\" ' 文档保存路径，默认和Excel文件同目录
    
    ' 提取数据验证的数据源
    dvSource = ws.Range("B9:C9").Validation.Formula1
    ' 拆分数据源中的单元格地址（适配单行多个独立单元格的情况）
    dvSource = Replace(dvSource, "=", "")
    sourceCells = Split(dvSource, ",")
    
    ' 创建Word应用实例
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = False ' 批量生成时隐藏Word，提升效率
    
    ' 遍历每个数据验证条目
    On Error Resume Next ' 防止单个条目出错中断整个循环
    For Each cellAddr In sourceCells
        dvItem = ws.Range(cellAddr).Value
        If dvItem <> "" Then ' 跳过空值条目
            ' 更新合并单元格的选中值
            ws.Range("B9:C9").Value = dvItem
            
            ' 创建新Word文档
            Set wordDoc = wordApp.Documents.Add
            
            ' 设置页面边距
            With wordDoc.PageSetup
                .LeftMargin = wordApp.InchesToPoints(0.4)
                .RightMargin = wordApp.InchesToPoints(0.4)
                .TopMargin = wordApp.InchesToPoints(0.4)
                .BottomMargin = wordApp.InchesToPoints(0.4)
            End With
            
            ' 复制Excel表格并粘贴到Word
            tbl.Copy
            wordDoc.Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
            
            ' 设置Word表格自适应窗口
            Set wordTable = wordDoc.Tables(1)
            wordTable.AutoFitBehavior 2 ' 用数值常量替代wdAutoFitWindow，无需引用Word对象库
            
            ' 保存文档（以数据验证条目作为文件名）
            wordDoc.SaveAs2 Filename:=savePath & dvItem & ".docx", FileFormat:=16 ' 用数值常量替代wdFormatXMLDocument
            
            ' 关闭当前Word文档
            wordDoc.Close
            Set wordDoc = Nothing
        End If
    Next cellAddr
    On Error GoTo 0
    
    ' 关闭Word应用并清理对象
    wordApp.Quit
    Set wordApp = Nothing
    Set tbl = Nothing
    Set ws = Nothing
    
    MsgBox "所有文档已批量生成完成！"
End Sub

关键代码说明 #

• 数据源提取：通过Validation.Formula1获取数据验证的数据源公式，拆分后得到每个单元格地址，读取对应单元格的值作为遍历条目
• 批量效率优化：将Word设置为隐藏状态，减少界面刷新开销；循环中创建文档后及时关闭，避免内存占用过高
• 兼容性处理：使用数值常量替代Word对象库中的命名常量，无需额外引用，避免版本兼容问题
• 错误防护：添加On Error Resume Next确保单个条目生成失败时，后续条目仍能继续执行

内容的提问来源于stack exchange，提问作者Meshan Silva