Замена текста в нескольких файлах Word

Question

Я новичок в vba, и я пытался найти код для поиска и замены текста в нескольких файлах Word, которые находятся в разных подпапках в основной папке. Моя проблема в том, что когда я запускаю свой код, кажется, что каждый файл открывается много раз, прежде чем перейти к следующему (или несколько раз переходит в одну и ту же подпапку, прежде чем перейти к следующей); однако этого не происходит, когда я запускаю код построчно, что действительно оставляет меня в растерянности; надеюсь, кто-то может дать некоторые ответы.

Sub DoLangesNow()
   Dim file
   Dim path As String
   Dim StrFolder As String
   Dim strSubFolder As String
   Dim strFile As String
   Dim colSubFolders As New Collection
   Dim varItem As Variant
   Dim myStoryRange As Range

     ' Parent folder
        StrFolder = "G:\Caminos de San Lorenzo II\"

     ' Loop through the subfolders 
        strSubFolder = Dir(StrFolder & "*", vbDirectory)

       Do While Not strSubFolder = ""
         Select Case strSubFolder
             Case ".", ".."
             ' Current folder or parent folder - ignore
             Case Else
             ' Add to collection
             colSubFolders.Add Item:=strSubFolder, Key:=strSubFolder
         End Select
     ' On to the next one
     strSubFolder = Dir
 Loop
 ' Loop through the collection
 For Each varItem In colSubFolders
     ' Loop through files in subfolder
     strFile = Dir(StrFolder & varItem & "\" & "*.doc")
     Do While strFile <> ""
     Set file = Documents.Open(FileName:=StrFolder & _varItem & "\" & strFile)
 ' Start of macro replace text x  with y
  For Each myStoryRange In ActiveDocument.StoryRanges
    With myStoryRange.Find
        .Text = "EDIFICIO CAPINURI"
        .Replacement.Text = "CONJUNTO RESIDENCIAL LOS CAMINOS DE SAN LORENZO II"
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
        .Text = "Olga Márquez"
        .Replacement.Text = "Glady Rubiano"
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
        .Text = "OLGA LEONOR MÁRQUEZ PAVA"
        .Replacement.Text = "GLADY MOLINA RUBIANO"
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
        .Text = "830.005.582-9"
        .Replacement.Text = "830.065.826-7"
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
        .Text = "Carrera 53 # 134 A - 71"
        .Replacement.Text = "Calle 146 A # 58 B - 85"
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
        .Text = "2588540"
        .Replacement.Text = "6241551"
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
        .Text = "313 4314549"
        .Replacement.Text = "312 4680338"
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
        .Text = " 24149562"
        .Replacement.Text = "0"
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
        .Text = "capinuriph@gmail.com"
        .Replacement.Text = "caminosdesanlorenzodos@gmail.com"
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
        .Text = "Positiva"
        .Replacement.Text = "Positiva"
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
        .Text = " ADMINISTRADORA"
        .Replacement.Text = "ADMINISTRADORA"
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
    End With
         Next myStoryRange
   ' End of macro 1
   ' Saves the file
         ActiveDocument.Save
         ActiveDocument.Close , (SaveChanges)
        ' set file to next in Dir
         strFile = Dir
       Loop
   Next varItem

End Sub

Answer 1

Если вам нужно найти / заменить один документ, это не страшно. Однако, если вам нужно сделать это для всех документов Word в папке, это может быть очень большим делом. Сценарий ниже представляет собой пакетный процесс, который выполняет процедуру поиска / замены для всех файлов Word в папке.

Sub FindReplaceAll()

    Dim MyDialog As FileDialog, GetStr(1 To 100) As String 
'100 files is the maximum applying this code
    On Error Resume Next
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
        .Filters.Clear
        .AllowMultiSelect = True
        i = 1
        If .Show = -1 Then
            For Each stiSelectedItem In .SelectedItems
                GetStr(i) = stiSelectedItem
                i = i + 1
            Next
            i = i - 1
        End If
        Application.ScreenUpdating = False
        For j = 1 To i Step 1
Set Doc = Documents.Open(FileName:=GetStr(j), Visible:=True)
Windows(GetStr(j)).Activate
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            With Selection.Find
                .Text = "Marriott International" 'Find What
                .Replacement.Text = "Marriott" 'Replace With
                .Forward = True
                .Wrap = wdFindAsk
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchByte = True
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
            End With
            Selection.Find.Execute Replace:=wdReplaceAll
Application.Run macroname:="NEWMACROS"
ActiveDocument.Save
            ActiveWindow.Close
        Next
        Application.ScreenUpdating = True
    End With
    MsgBox "operation end, please view", vbInformation

End Sub

Answer 2

Итак, я просмотрел еще несколько постов в Интернете о поиске и замене слов в нескольких файлах / подпапках / папках и, наконец, закончил с этим, который, кажется, прекрасно работает:

Sub DoLangesNow()
    Dim file
    Dim path As String
    Dim StrFolder As String
    Dim strSubFolder As String
    Dim strFile As String
    Dim colSubFolders As New Collection
    Dim varItem As Variant
    Dim myStoryRange As Range
    Dim i As Long
    Dim TargetList
    Dim MyRange As Range
    TargetList = Array("EDIFICIO CAPINURI", "Olga Márquez", "OLGA LEONOR MÁRQUEZ PAVA", "830.005.582-9", "Carrera 53 # 134 A - 71", "2588540", "313 4314549", "24149562", "capinuriph@gmail.com", "Positiva", "ADMINISTRADORA", "POSITIVA") ' put list of terms to find here
    Dim sStringToAdd
    sStringToAdd = Array("EDIFICIO TORRE 95", "Claudia Cárdenas", "CLAUDIA CARDENAS PEREZ", "959.011.545-0", "Calle 95 # 21 - 34", "-", "3043982237", "51798184", "aedyco@yahoo.com", "Positiva", "ADMINISTRADORA", "POSITIVA")


    ' Parent folder
    StrFolder = "G:\Prueba\"

    ' Loop through the subfolders
    strSubFolder = Dir(StrFolder & "*", vbDirectory)

    Do While Not strSubFolder = ""
        Select Case strSubFolder
            Case ".", ".."
                ' Current folder or parent folder - ignore
            Case Else
                ' Add to collection
                colSubFolders.Add Item:=strSubFolder, Key:=strSubFolder
        End Select
        ' On to the next one
        strSubFolder = Dir
    Loop
    ' Loop through the collection
    For Each varItem In colSubFolders
        Debug.Print varItem
        ' Loop through files in subfolder
        strFile = Dir(StrFolder & varItem & "\" & "*.doc")
        Do While strFile <> ""
            Debug.Print strFile
            Set file = Documents.Open(FileName:=StrFolder & varItem & "\" & strFile)
            ' Start of macro replace text x  with y

            For i = 0 To UBound(TargetList)

                Set MyRange = ActiveDocument.Content

                MyRange.Find.Execute FindText:=TargetList(i), ReplaceWith:=sStringToAdd(i), _
                                     Replace:=wdReplaceAll

                Set MyRange = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range

                MyRange.Find.Execute FindText:=TargetList(i), ReplaceWith:=sStringToAdd(i), _
                                     Replace:=wdReplaceAll

                Set MyRange = ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range

                MyRange.Find.Execute FindText:=TargetList(i), ReplaceWith:=sStringToAdd(i), _
                                    Replace:=wdReplaceAll
            Next i


            '   ' End of macro 1
            '   ' Saves the file
            ActiveDocument.Save
            ActiveDocument.Close
            ' set file to next in Dir
            strFile = Dir
        Loop
    Next varItem
End Sub

Спасибо Синди Майстер за помощь!