跟据excel每行的内容，替换模版word对应关键字，并另存为

wyysmj

如附件，有个excel是原始数据，第一行标题就是对应的word模板关键字的，其余的行都是具体数据，如何读取word模板内容，自动替换关键字，并另存为。比如excel有十行，就自动替换生成十个word文件。


感谢各位大佬了，小弟在此先谢过了~~~~

gwjkkkkk

邮件合并。。。

wyysmj

gwjkkkkk 发表于 2024-4-11 11:47
邮件合并。。。

实际的excel列和行都很多，列大概有50多，行有200多人。 邮件合并设置还是有点累。 想用vba的自动循环

一执成念

论坛搜索xls2doc，现成的工具

3190496160

excel的vba操作word本身就非常繁琐，楼主目前上传的附件，两个字：等等，别人根据你目前上传的附件写出代码来，你能融会贯通吗？如果不能，最好还是上传你真实的excel文件和word模板，不然，写出代码来，你还得不断追问的，而论坛是做义务的，没有人会有多好耐性在一个问题上反复折腾的，

wyysmj

3190496160 发表于 2024-4-11 15:21
excel的vba操作word本身就非常繁琐，楼主目前上传的附件，两个字：等等，别人根据你目前上传的附件写出代码 ...

格式和真实的已经是一模一样了， 只是数据量不同了。只要样例能成功，真实的文本那肯定是没问题的。而且具体代码还是能看的懂的，只是vba没有从头学过，所以凭空写对我来讲还是有点难度，不过如果是在已有代码上调整，那应该还是没问题的。

3190496160

Sub 按模板生成文档()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim i%, k%, x%, arr, d, krr, kr, myPath$, wdApp, wdD
Dim oFso
Set oFso = CreateObject("Scripting.FileSystemObject")
myPath = ThisWorkbook.Path & "\"
Set wdApp = CreateObject("word.application")
wdApp.Visible = True
arr = Sheets("Sheet1").Range("A1:e" & Cells(Rows.Count, 1).End(xlUp).Row)
For i = 2 To UBound(arr)
    If Trim(arr(i, 1)) <> "" Then
        FileCopy myPath & "简化测评模板.docx", myPath & "生成的文件\" & arr(i, 1) & "-" & arr(i, 2) & ".docx"
        Set wdD = wdApp.Documents.Open(myPath & "生成的文件\" & arr(i, 1) & "-" & arr(i, 2) & ".docx")
        For j = 1 To 2
            With wdApp
                .Selection.HomeKey unit:=6 'wdStory '光标置于文件首
                If .Selection.Find.Execute(arr(1, j)) Then '查找到指定字符串
                   .Selection.Text = arr(i, j) '替换字符串
                End If
            End With
        Next j
        With wdD.Tables(1)
            For j = 3 To UBound(arr, 2)
                .Cell(j - 1, 2).Range.Text = arr(i, j)
            Next j
        End With
        wdD.Save
        wdD.Close
    End If
Next i
wdApp.Quit
Set wdD = Nothing
Set wdApp = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = False
MsgBox "ok!"
End Sub

3190496160

测试数据.rar (46.1 KB, 下载次数: 11)

2024-4-11 16:03 上传

点击文件名下载附件

gwjkkkkk

Option Explicit
Sub TEST加dir()
    Dim wdApp As Word.Application, strFileName$, strPath$
    Dim ar, i&, j&, wdDoc As Word.Document, f$
    strPath = ThisWorkbook.Path & "\"
    strFileName = strPath & "简化测评模板.docx"
    If Dir(strFileName) = "" Then MsgBox "指定的文件不存在，请检查！", vbExclamation: Exit Sub

    Application.ScreenUpdating = False
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err <> 0 Then
        Set wdApp = New Word.Application
    End If
   
    ar = [A1].CurrentRegion.Value
    For i = 2 To UBound(ar)
       Set wdDoc = wdApp.documents.Open(strFileName)
       f = strPath & ar(i, 1)
       With wdDoc
           For j = 1 To UBound(ar, 2)
              With .Content.Find
                 .Text = ar(1, j)
                 .Replacement.Text = ar(i, j)
                 .Execute Replace:=wdReplaceAll
              End With
           Next j
       End With
       wdDoc.SaveAs f: wdDoc.Close
    Next i
        
    If Err <> 0 Then wdApp.Quit
    Set wdApp = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。