批量替换文件夹和子文件里word的多处内容

xcz123m

大家好  需要批量替换文件夹内各个子文件夹内word的多处内容，例如：1.承包面积：0.00亩    替换成     地块用途：种植业   2.承包面积：  替换成    地块用途 ： 3.二轮合同总面积(亩)：0.00亩    替换成    行政村：芦玮         需要可以批量多组替换的VBA

朝露孤烟

考虑用批量文本替换工具处理吧。

xcz123m

朝露孤烟 发表于 2024-8-25 12:16
考虑用批量文本替换工具处理吧。

一般一次只能替换一组吧

gwjkkkkk

Option Explicit
Option Compare Text
Sub test1()
    Dim ar(), br, i&, j&, wdApp As Word.Application

    Call vFilesListDg(ThisWorkbook.Path, ar(), i, "doc*", ThisWorkbook.Name)
    If i = 0 Then Exit Sub
   
    Application.ScreenUpdating = False
    br = [A1].CurrentRegion.Value
   
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err <> 0 Then
        Set wdApp = New Word.Application
    End If
   
    For j = 1 To UBound(ar)
        With wdApp.documents.Open(ar(j))
            For i = 2 To UBound(br)
                With .Content.Find
                    .ClearFormatting
                    .Text = br(i, 1)
                    .Replacement.ClearFormatting
                    .Replacement.Text = br(i, 2)
                    .Execute Replace:=wdReplaceAll
                 End With
            Next i
            .Close True
        End With
    Next j
   
    If Err <> 0 Then wdApp.Quit
    Set wdApp = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

Function vFilesListDg(ByVal strPath$, ByRef ar(), Optional ByRef iGroup&, Optional ByVal strExtension$ = "*", _
    Optional ByVal strExclude As String = "", Optional ByVal isFolder As Boolean)
   
    Dim Fso As Object, objFold As Object, vFile, vFold
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set objFold = Fso.GetFolder(strPath)
    If isFolder Then
        For Each vFile In objFold.subfolders
            iGroup = iGroup + 1
            ReDim Preserve ar(1 To iGroup)
            ar(iGroup) = vFile.Path
        Next
    Else
        For Each vFile In objFold.Files
            If Fso.GetExtensionName(vFile.Name) Like strExtension Then
                If vFile.Name <> strExclude And Not vFile.Name Like "~$*" Then
                    iGroup = iGroup + 1
                    ReDim Preserve ar(1 To iGroup)
                    ar(iGroup) = vFile.Path
                End If
            End If
        Next
    End If
    For Each vFold In objFold.subfolders
        vFilesListDg vFold, ar, iGroup, strExtension, strExclude, isFolder
    Next vFold
End Function

gwjkkkkk

。。。。。。。。。。。

xcz123m

gwjkkkkk 发表于 2024-8-25 19:33
Option Explicit
Option Compare Text
Sub test1()

谢谢    学习到了。。

xcz123m

gwjkkkkk 发表于 2024-8-25 19:34
。。。。。。。。。。。

很好用 谢谢

Enocheasty

我之前编写过一个Word批量替换工具，可以搞这个事！！
https://club.excelhome.net/thread-1689500-1-1.html
所谓的替换项就是你要求的1,2，3个替换内容，将替换内容依次添加后，程序会在每个文档中执行所有的替换。

xcz123m

Enocheasty 发表于 2024-8-31 14:37
我之前编写过一个Word批量替换工具，可以搞这个事！！
https://club.excelhome.net/thread-1689500-1-1.ht ...

谢谢  我试试