有条件批量替换word文件中的内容

sunshuangzhong

word文件：

limonet

Sub limonet()
    Dim Arr As Variant, Brr As Variant, i%
    Arr = Array("G1", "G2", "G3")
    Brr = Array(2002, 2005, 2007)
    For i = 0 To UBound(Arr)
        With Selection.Find
            .Text = Arr(i)
           .Execute
        End With
        Selection.MoveRight Unit:=wdCell, Count:=2
        Selection.TypeText Text:=Brr(i)
    Next i
End Sub

limonet

selection.find

sunshuangzhong

limonet 发表于 2024-12-18 15:51
selection.find

你的代码写在word里的?

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim wordapp As Object
   
5.     Dim worddoc As Object
   
6.     Dim mypath$, myname$
   
7.     Dim flg As Boolean
   
8.     Dim d As Object
   
9.     Set d = CreateObject("scripting.dictionary")
   
10.     Application.ScreenUpdating = False
    
11.     Application.DisplayAlerts = False
    
12.     mypath = ThisWorkbook.Path & ""
    
13.     myname = "word文件.docx"
    
14.     If Dir(mypath & myname) = "" Then
    
15.         MsgBox mypath & myname & "不存在！"
    
16.         Exit Sub
    
17.     End If
    
18.     With Worksheets("sheet1")
    
19.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
20.         If r = 1 Then
    
21.             Exit Sub
    
22.         End If
    
23.         arr = .Range("a2:b" & r)
    
24.         For i = 1 To UBound(arr)
    
25.             d(arr(i, 1)) = arr(i, 2)
    
26.         Next
    
27.     End With
    
28.     On Error Resume Next
    
29.     Set wordapp = GetObject(, "word.application")
    
30.     If Err Then
    
31.         flg = True
    
32.         Set wordapp = CreateObject("word.application")
    
33.     End If
    
34.     On Error GoTo 0
    
35.     Set worddoc = wordapp.documents.Open(mypath & myname)
    
36.     With worddoc
    
37.         For i = 1 To .tables.Count
    
38.             With .tables(i)
    
39.                 xm = Replace(.cell(5, 2).Range.Text, Chr(13) & Chr(7), Empty)
    
40.                 If d.exists(xm) Then
    
41.                     .cell(5, 4).Range.Text = d(xm)
    
42.                 End If
    
43.             End With
    
44.         Next
    
45.         .Close True
    
46.     End With
    
47.     If flg Then
    
48.         wordapp.Quit
    
49.     End If
    
50.     Application.ScreenUpdating = True
    
51.     MsgBox "数据提取完毕！"
    
52. End Sub
    
53. 
    
54. 
    

复制代码

chxw68

详见附件。

杨建营

混个积分。

sunshuangzhong

chxw68 发表于 2024-12-18 15:56
详见附件。

正是我想要的，感谢褚老师的无私奉献！

lizhipei78

https://club.excelhome.net/threa ... tml?_dsign=141af79a

gwjkkkkk

Option Explicit
Sub test2()
Dim ar, i&, wdApp As Word.Application, strFileName$, strPath$, objTab As Word.Table

    strPath = ThisWorkbook.Path & "\"
    strFileName = strPath & "word文件.docx"
    If Dir(strFileName) = "" Then MsgBox "文件不存在，请检查！", vbExclamation: Exit Sub
   
    Application.ScreenUpdating = False
   
    ar = [A1].CurrentRegion.Value
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err <> 0 Then
        Set wdApp = New Word.Application
    End If
   
    With wdApp.Documents.Open(strFileName)
        For i = 2 To UBound(ar)
            For Each objTab In .Tables
                With objTab
                    If .Range.Cells(18).Range.Text = ar(i, 1) & Chr(13) & Chr(7) Then
                        .Range.Cells(20).Range.Text = ar(i, 2)
                        Exit For
                    End If
                End With
            Next
        Next i
        .Close True
    End With
   
    If Err <> 0 Then wdApp.Quit
    Set wdApp = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub