通过vba将execl数据批量录入word文档

同心/ty

首先，祝大师们元旦节快乐。，新年之始发个贴，求大家帮忙了。
要求通过数据表中编号查找word文件（提供的word文件名里带有编号），向word文件中写入数据信息，
            1. 在word文件中“承包期限”信息里将“2014年10月15日至2028年12月31日”全部替换成“2014年10月15日至2028年12月31日延长到：2029年1月1日至2058年12月31日止"   （指示:这个单元格内容是固定的）
    2.在word文件中"农村土地承包经营权证流水号及不动产权证号"信息里，补加数据表中编号对应的不动产号信息。（这个单元格内容是不定的）效果如图。

蓝桥玄霜

数据源的例子：

wxxydl

Sub test()
    Application.ScreenUpdating = False
    arr = Worksheets("sheet1").UsedRange
    Set doc = CreateObject("word.application")
    f = Dir(ThisWorkbook.Path & "\*.doc")
    Do While f <> ""
        rr = Left(f, 18)
        For i = 1 To UBound(arr)
            If arr(i, 2) = rr Then
                s1 = arr(i, 4)
                s2 = arr(i, 5)
                Exit For
            End If
        Next
        Set wd = doc.Documents.Open(ThisWorkbook.Path & "\" & f)
        'doc.Visible = True
        With wd.tables(1)
            .Cell(11, 2) = s1
            .Cell(14, 2) = s2
        End With
   
        f = Dir
        wd.Close True
    Loop
    Application.ScreenUpdating = True
End Sub

wxxydl

我给你做了一个  看一下

同心/ty

wxxydl 发表于 2023-12-30 11:38
我给你做了一个  看一下

老师，你的代码我测试了一下，不动产号要求在原信息后添加上去，而你代码的效果是完全替换，老师，能不能再修改一下？


效果如图

同心/ty

蓝桥玄霜 发表于 2023-12-30 11:29
数据源的例子：

老师，我按你的代码抄了一遍，执行后，文字一直在加，不停止。

同心/ty

蓝桥玄霜 发表于 2023-12-30 11:29
数据源的例子：

老师，多谢你编写的代码，能按我的要求添加对应的数据，但一直循环的加入，不停止。在你的代码基础上我修改了一下，顺利的写入完成。
Sub lqxs()
    Dim WD As Object, DC As Object
    Dim tb As Object, bm$, nm$, myPath$, myName$
    Dim Arr, i%, d, n%, s4$
   
    Set d = CreateObject("Scripting.Dictionary")
    Set WD = CreateObject("Word.Application")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
     
    Sheet1.Activate
    Arr = Range("A1").CurrentRegion
    For i = 2 To UBound(Arr)
        bm = Arr(i, 2) & "_" & Arr(i, 3) & "_登记簿"
        d(bm) = i
    Next
    myPath = ThisWorkbook.Path & "\"
    Set objFolder = objFSO.GetFolder(myPath)
   
    For Each objFile In objFolder.Files
        If LCase(Right(objFile.Name, 4)) = ".doc" Then
        nm = Split(objFile.Name, ".")(0)
       If d.exists(nm) Then
       n = d(nm)
       Set DC = WD.documents.Open(myPath & objFile.Name)
       WD.Visible = True
       Set tb = DC.tables(1)
       With tb
       .Range.Cells(22).Range.Text = Arr(n, 4)
        s4 = .Range.Cells(28).Range.Text
       .Range.Cells(28).Range.Text = s4 & Arr(n, 5)
    End With
    DC.Close True
  End If
    End If
    Next objFile
   
  Set WD = Nothing
End Sub

wxxydl

已改。。。。。。。。。。。。。。。

同心/ty

wxxydl 发表于 2023-12-30 20:17
已改。。。。。。。。。。。。。。。

老师，你的代码精简，将其中& Chr(13)回车符 删除，就正常显示了，否则就多了一个空白行，不动产号就显示隐藏了，谢谢老师的帮助。

同心/ty

wxxydl 发表于 2023-12-30 20:17
已改。。。。。。。。。。。。。。。

老师，你的代码投入应用，效果很好，但不便的是，每次要把多个登记簿文件复制到运行vba文件的根目录上，有点麻烦，能否实现选择磁盘挑选文件对话框来运作。