VBA如何实现批量修改多个word文档里的内容，要修改的记录以Excel体现

open158

小白求各位大侠帮忙：
手上有上千的word，案例只拿了12为例，需要修改word里面指定的内容，每个word里面的格式都一样。指定修改的地方在Excel里体现，如何用VBA实现？
具体上图：
1、word第一页要修改的内容是三个地方：宗地/宗海代码、调查单位（机构）、调查时间。修改的内容与Excel表格里的内容对应。
2、word第二页要修改的内容是三个地方：权利类型、权利性质、宗地代码、不动产单元号，第二页开始是表格的形式。修改的内容为对应的Excel表格里的内容。
3、word第7页要修改的内容是word里的第4个表格里的内容：权属调查记事、地籍测量记事。修改的内容为对应的Excel表格里的内容。
详见附图，辛苦大侠们了！

3190496160

这个问题，不简单，先留个足印吧

约定的童话

邮件合并的形式吧，准备一份空模板，然后VBA一键批量填写生成模板，网上有案例，感觉还是VBA快捷方便

魂断蓝桥

Option Explicit
Sub A()
    Dim appWD, doc As Object, arr, i%, j%, M%, ran
    Set appWD = CreateObject("Word.Application")
    arr = [B1].CurrentRegion
    For i = 2 To UBound(arr)
        Set doc = appWD.Documents.Open(ThisWorkbook.Path & "\" & arr(i, 2))
        appWD.Visible = 0
        appWD.Selection.HomeKey unit:=6
        Set ran = appWD.Application.ActiveDocument.Range
        For j = 3 To 5
            With ran.Find
                .ClearFormatting
                .Text = arr(1, j)
                .Forward = 1
                .Wrap = 1
                If .Execute Then
                    M = ran.Start
                    appWD.ActiveDocument.Range(M, M).Select
                    appWD.Selection.MoveDown unit:=4, Extend:=1
                    appWD.Selection.Text = arr(1, j) & "：" & arr(i, j) & Chr(13)
                End If
            End With
        Next
        appWD.ActiveDocument.Tables(1).Cell(7, 2).Range.Text = arr(i, 6)
        appWD.ActiveDocument.Tables(1).Cell(7, 4).Range.Text = arr(i, 7)
        appWD.ActiveDocument.Tables(1).Cell(15, 4).Range.Text = arr(i, 8)
        appWD.ActiveDocument.Tables(1).Cell(16, 2).Range.Text = arr(i, 9)
        appWD.ActiveDocument.Tables(4).Cell(5, 2).Range.Text = arr(i, 10)
        appWD.ActiveDocument.Tables(4).Cell(7, 2).Range.Text = arr(i, 11)
        doc.Close
    Next
    appWD.Quit
End Sub

open158

魂断蓝桥 发表于 2020-3-18 10:28
Option Explicit
Sub A()
    Dim appWD, doc As Object, arr, i%, j%, M%, ran

试了可以用，太感谢了，牛人果然不一样！

open158

约定的童话 发表于 2020-3-18 10:08
邮件合并的形式吧，准备一份空模板，然后VBA一键批量填写生成模板，网上有案例，感觉还是VBA快捷方便

邮件合并没有VBA强大，因为修改的内容只是word当中的部分内容。

约定的童话

魂断蓝桥 发表于 2020-3-18 10:28
Option Explicit
Sub A()
    Dim appWD, doc As Object, arr, i%, j%, M%, ran

你这ID跟蓝版是一个ID吧？

johncby

非常感谢！学习中！

plg123

魂断蓝桥 发表于 2020-3-18 10:28
Option Explicit
Sub A()
    Dim appWD, doc As Object, arr, i%, j%, M%, ran

大师厉害，请问增加一个功能，修改每个word的初始页码怎么写代码？比如设置所有word初始页码为20？doc.Sections(1).Footers(1).PageNumbers.StartingNumber = 20 无效，盼大师回复，谢谢。

wps6129

魂断蓝桥 发表于 2020-3-18 10:28
Option Explicit
Sub A()
    Dim appWD, doc As Object, arr, i%, j%, M%, ran

太厉害了， 学习一下