excel实现生成word信函的功能，具体如图。

Meゑゑ

excel实现生成word信函的功能，具体如图。点击一次生成，（如果鼠标放在某一行）就生成一个该行对应的word文档。

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, i&, j&, tRow&, wdApp As Word.Application, strFileName$, strPath$
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = strPath & "证书.docx"
    If Dir(strFileName) = "" Then MsgBox "指定的文件不存在，请检查！", vbExclamation: Exit Sub
   
    ar = [A1].CurrentRegion.Value
    If ActiveCell.Row = 1 Or ActiveCell.Row > UBound(ar) Then
        MsgBox "请正确选择": Exit Sub
    Else
        tRow = ActiveCell.Row
    End If
   
    If ar(tRow, 3) = Empty Then MsgBox "姓名为空": Exit Sub
   
    Application.ScreenUpdating = False
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err <> 0 Then
        Set wdApp = New Word.Application
        'wdApp.Visible = True
    End If
   
    With wdApp.documents.Open(strFileName)
        strFileName = strPath & ar(tRow, 3)
        For j = 1 To UBound(ar, 2)
            With .Content.Find
                .ClearFormatting
                .Text = "数据" & Format(j, "000")
                .Replacement.ClearFormatting
                .Replacement.Text = ar(tRow, j)
                .Execute Replace:=wdReplaceAll
             End With
        Next j
        .SaveAs2 strFileName
        .Close
    End With
   
    If Err <> 0 Then wdApp.Quit
    Set wdApp = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考。。。

taller

Word文档中创建书签（Bookmark），VBA代码进行替换，如果批量创建证书，那么应该使用Word邮件合并功能，无需任何代码。

1. Private Sub CreateCert()
   
2.     Dim objWord As Object
   
3.     Dim objDoc, aBM, sTxt As String, i As Long
   
4.     Set objWord = CreateObject("Word.Application")
   
5. '    Set objWord = GetObject(, "Word.Application")
   
6.     objWord.Visible = False
   
7.     Set objDoc = objWord.Documents.Open(ThisWorkbook.Path & "\证书.docx")
   
8.     aBM = Array("comp", "name", "cate", "date")
   
9.     With Selection
   
10.         If .Cells.Count > 1 Or .Cells(1).Row = 1 Then Exit Sub
    
11.         For i = 0 To UBound(aBM)
    
12.             objDoc.bookmarks(aBM(i)).Range.Text = Cells(.Row, i + 2)
    
13.         Next
    
14.         objDoc.SaveAs ThisWorkbook.Path & "\证书" & Cells(.Row, 1) & ".docx"
    
15.     End With
    
16.     objDoc.Close
    
17.     objWord.Quit
    
18.     Set objDoc = Nothing
    
19.     Set objWord = Nothing
    
20.     MsgBox "done"
    
21. End Sub
    

复制代码

chxw68

参与一下。

Meゑゑ

gwjkkkkk 发表于 2024-8-25 17:37
请参考。。。

提示编译错误！无法运行，可以解决吗

sdytsxd991122

gwjkkkkk

Meゑゑ 发表于 2024-8-25 18:11
提示编译错误！无法运行，可以解决吗

重新引用一下。。。

Meゑゑ

chxw68 发表于 2024-8-25 18:11
参与一下。

好用，但是重名的话，无法解决！如何修改？

chxw68

Meゑゑ 发表于 2024-8-25 19:30
好用，但是重名的话，无法解决！如何修改？

什么重名？