Excel VBA代码修改需求：按申请才艺生成含全体学生的Word文档

问题描述 #

我正在开发Excel VBA代码，要将Excel数据生成Word文档，期望按「Talent Applied 1」分类保存为Basketball.docx、Choir.docx等文件。但当前代码仅能生成单个学生的对应文档，同类别下的下一位学生保存时会因重名报错。

需求目标：每个分类文档（如Basketball.docx）需包含对应类别的所有学生信息，且套用指定Word模板格式。

现有代码 #

Sub ReplaceText()
Dim wApp As Word.Application
Dim wdoc As Word.Document
Dim custN, path As String
Dim r As Long
r = 2
Do While Sheets("DSA-Sec Sch Applicants Detail").Cells(r, 1).Value <> ""
Set wApp = CreateObject("Word.Application")

wApp.Visible = True


Set wdoc = wApp.Documents.Open(Filename:="C:\Users\S1234567D\Downloads\DSA\Collated DSA.dotx", ReadOnly:=True)
With wdoc
    .Application.Selection.Find.Text = "<<MAIN CONTACT>>"
    .Application.Selection.Find.Execute
    .Application.Selection = Sheet1.Cells(r, 2).Value
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<<NAME>>"
    .Application.Selection.Find.Execute
    .Application.Selection = Sheet1.Cells(r, 3).Value
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<<TALENT APPLIED 1>>"
    .Application.Selection.Find.Execute
    .Application.Selection = Sheet1.Cells(r, 1).Value
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<<DSA Date>>"
    .Application.Selection.Find.Execute
    .Application.Selection = Sheet1.Cells(r, 4).Value
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<<DSA Day>>"
    .Application.Selection.Find.Execute
    .Application.Selection = Sheet1.Cells(r, 5).Value
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<<DSA Time>>"
    .Application.Selection.Find.Execute
    .Application.Selection = Sheet1.Cells(r, 6).Value
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<<TALENT APPLIED 1>>"
    .Application.Selection.Find.Execute
    .Application.Selection = Sheet1.Cells(r, 1).Value
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<<Perform Task>>"
    .Application.Selection.Find.Execute
    .Application.Selection = Sheet1.Cells(r, 7).Value
    .Application.Selection.EndOf
    
    custN = Sheet1.Cells(r, 1).Value
    path = "C:\Users\S1234567D\Downloads\DSA\"
    .SaveAs2 Filename:=path & custN, _
    FileFormat:=wdFormatXMLDocument, AddtoRecentFiles:=False
End With
r = r + 1
Loop

End Sub

修改后的代码 #

Sub GenerateCategoryDocs()
    Dim wApp As Word.Application
    Dim wdoc As Word.Document
    Dim ws As Worksheet
    Dim lastRow As Long, r As Long
    Dim category As String
    Dim docDict As Object ' 存储已打开的分类文档
    Dim templatePath As String, savePath As String
    Dim key As Variant
    
    ' 初始化变量
    Set ws = ThisWorkbook.Sheets("DSA-Sec Sch Applicants Detail")
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    templatePath = "C:\Users\S1234567D\Downloads\DSA\Collated DSA.dotx"
    savePath = "C:\Users\S1234567D\Downloads\DSA\"
    Set docDict = CreateObject("Scripting.Dictionary")
    
    ' 启动Word应用
    Set wApp = CreateObject("Word.Application")
    wApp.Visible = True
    
    ' 遍历所有学生数据
    For r = 2 To lastRow
        category = ws.Cells(r, 1).Value
        If Trim(category) = "" Then GoTo NextRow
        
        ' 检查当前分类是否已有打开的文档
        If Not docDict.Exists(category) Then
            ' 从模板新建文档
            Set wdoc = wApp.Documents.Add(Template:=templatePath, NewTemplate:=False, DocumentType:=0)
            docDict.Add category, wdoc ' 存入字典
        Else
            Set wdoc = docDict(category) ' 取出已有的文档
        End If
        
        ' 定位到文档末尾，准备添加新学生内容
        wdoc.Content.InsertAfter vbCrLf & vbCrLf ' 用空行分隔不同学生
        wdoc.Content.Select
        wApp.Selection.EndKey Unit:=wdStory
        
        ' 替换当前学生的占位符
        With wApp.Selection.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            
            ' 替换MAIN CONTACT
            .Text = "<<MAIN CONTACT>>"
            .Replacement.Text = ws.Cells(r, 2).Value
            .Execute Replace:=wdReplaceOne
            
            ' 替换NAME
            .Text = "<<NAME>>"
            .Replacement.Text = ws.Cells(r, 3).Value
            .Execute Replace:=wdReplaceOne
            
            ' 替换TALENT APPLIED 1
            .Text = "<<TALENT APPLIED 1>>"
            .Replacement.Text = category
            .Execute Replace:=wdReplaceOne
            
            ' 替换DSA Date
            .Text = "<<DSA Date>>"
            .Replacement.Text = ws.Cells(r, 4).Value
            .Execute Replace:=wdReplaceOne
            
            ' 替换DSA Day
            .Text = "<<DSA Day>>"
            .Replacement.Text = ws.Cells(r, 5).Value
            .Execute Replace:=wdReplaceOne
            
            ' 替换DSA Time
            .Text = "<<DSA Time>>"
            .Replacement.Text = ws.Cells(r, 6).Value
            .Execute Replace:=wdReplaceOne
            
            ' 替换Perform Task
            .Text = "<<Perform Task>>"
            .Replacement.Text = ws.Cells(r, 7).Value
            .Execute Replace:=wdReplaceOne
        End With
        
NextRow:
    Next r
    
    ' 保存并关闭所有分类文档
    For Each key In docDict.Keys
        Set wdoc = docDict(key)
        wdoc.SaveAs2 Filename:=savePath & key & ".docx", _
                     FileFormat:=wdFormatXMLDocument, AddtoRecentFiles:=False
        wdoc.Close
    Next key
    
    ' 退出Word应用
    wApp.Quit
    Set wApp = Nothing
    Set docDict = Nothing
    Set ws = Nothing
    
    MsgBox "所有分类文档已生成完成！"
End Sub

关键改动说明 #

• 字典管理分类文档：用Scripting.Dictionary记录已创建的分类文档，避免重复创建和重名覆盖问题。
• 批量追加同分类内容：每个分类仅初始化一次文档，后续同分类学生内容直接追加到文档末尾，保证一个文档包含所有同分类学生信息。
• 优化替换逻辑：使用Find.Replacement批量替换占位符，比原代码的Selection操作更高效稳定，减少出错概率。
• 统一保存关闭：遍历字典的键值对统一保存所有文档，确保文件名和路径正确，最后自动关闭Word应用，释放系统资源。

内容的提问来源于stack exchange，提问作者Wisefool Elliot