Excel表格数据填充到word模板中

2024年1月15日 163次阅读 来源: bjjgq

        这个需求源于要批量生成模板一样的word文档。当然可以直接使用word的邮件合并功能，点菜单就可以实现，示例代码如下：

       要使用这些代码，需要引用2个库microsoft word,microsoft office，如果使用到客体界面的话，还要引用microsoft Forms。本代码可以同时利用两个模板生成新的文档。其原理就是查找替换，没啥，减轻工作量。

Sub cmdPrinta_Click()
    
    Dim mypath$, mypathN$, aar1
    Dim r1%, r2%, n2%, j%
    
    Dim Wordapp As Word.Application
    Dim WordD As Word.Document      '定义word类
    Set Wordapp = New Word.Application  '这里需要一个新的
    
    'Wordapp.ScreenUpdating =False             '屏幕刷新
    'Set WordD = Wordapp.Documents.Add                  '新建文档
    If Len(txtlujing) > 1 Then
        mypathN = txtlujing
    Else
        mypathN = ThisWorkbook.Path & "\"
    End If
    mypath = ThisWorkbook.Path & "\"
    
    '初始化参数，要替换
    aar1 = Sheets("说明文字").Range("c5:d23")
    tbldata = "sheet1"
    tepdoc1 = "模板1.docx"
    tepdoc2 = "模板2.docx"


    With Wordapp  '这里需要是application
        .Visible = False
        r1 = TextBox1
        r2 = TextBox2
        For n2 = r1 To r2
            '第一个“模板1”,将模板复制并重命名
            Newname = "说明-" & Sheets(tbldata).Range("D" & n2) & "_" & _
                     Sheets(tbldata).Range("B" & n2) & ".docx"
            FileCopy mypath & tepdoc1, mypath & Newname
            .Documents.Open mypath & Newname, Visible = False '打开我们复制的新文件进行更改
            
            '替换各个变量
            For j = 1 To UBound(aar1, 1)
                .Selection.Find.ClearFormatting
                .Selection.Find.Replacement.ClearFormatting
                If j < 16 Then
                    '第i行的数据
                    strn = Sheets(tbldata).Cells(n2, aar1(j, 2))
                Else
                    strn = Sheets(tbldata).Range(aar1(j, 2))
                End If
                With .Selection.Find
                    .Text = "(" & aar1(j, 1) & ")"
                    .Replacement.Text = strn
                    .Forward = True
                    .Wrap = wdFindContinue
                    .Format = False
                    .MatchCase = False
                    .MatchWholeWord = False
                    .MatchByte = True
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                End With
                .Selection.Find.Execute Replace:=wdReplaceAll
            Next j
            .Documents.Save
            
            '第二个“模板2”
            Newname = "报告-" & Sheets(tbldata).Range("D" & n2) & "_" & _
                     Sheets(tbldata).Range("B" & n2) & ".docx"
            FileCopy mypath & tepdoc2, mypath & Newname
            .Documents.Open mypath & Newname, Visible = False
            
            '替换各个变量
            For j = 1 To UBound(aar1, 1)
                .Selection.Find.ClearFormatting
                .Selection.Find.Replacement.ClearFormatting
                If j < 16 Then
                    '第i行的数据
                    strn = Sheets(tbldata).Cells(n2, aar1(j, 2))
                Else
                    strn = Sheets(tbldata).Range(aar1(j, 2))
                End If
                With .Selection.Find
                    .Text = "(" & aar1(j, 1) & ")"
                    .Replacement.Text = strn
                    .Forward = True
                    .Wrap = wdFindContinue
                    .Format = False
                    .MatchCase = False
                    .MatchWholeWord = False
                    .MatchByte = True
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                End With
                .Selection.Find.Execute Replace:=wdReplaceAll
            Next j
           ' .Documents.Save
            .Documents(Newname).Close savechanges:=wdSaveChanges
            
        Next n2
    End With
    Wordapp.Quit
    MsgBox "输出完成,请到" & mypathN & "下查找", vbOKOnly, "提示"

End Sub

    原文作者：bjjgq
    原文地址: https://blog.csdn.net/bjjgq/article/details/123999087
    本文转自网络文章，转载此文章仅为分享知识，如有侵权，请联系博主进行删除。
点赞