Нужна помощь в объединении 2 кодов VBA

Question

Мне нужно объединить эти два кода VBA. Первый - это поиск и замена нескольких элементов в одном документе, а второй - поиск и замена слова во всей папке. Как вы можете себе представить, мне нужно найти и заменить несколько слов в каждом документе в папке с 1 кнопкой.

КОД 1:

Sub FindAndReplaceMultiItems()
  Dim strFindText As String
  Dim strReplaceText As String
  Dim nSplitItem As Long

  Application.ScreenUpdating = False

  ' Enter items to be replaces and new ones.
  strFindText = InputBox("Enter items to be found here,seperated by comma: ", "Items to be found")
  strReplaceText = InputBox("Enter new items here, seperated by comma: ", "New items")
  nSplitItem = UBound(Split(strFindText, ","))

  ' Find each item and replace it with new one respectively.
  For nSplitItem = 0 To nSplitItem
    With Selection
      .HomeKey Unit:=wdStory
      With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = Split(strFindText, ",")(nSplitItem)
        .Replacement.Text = Split(strReplaceText, ",")(nSplitItem)
        .Format = False
        .MatchWholeWord = False
      End With
    Selection.Find.Execute Replace:=wdReplaceAll
  End With
Next nSplitItem

  Application.ScreenUpdating = True

End Sub

КОД 2:

Sub FindAndReplaceInFolder()
  Dim objDoc As Document
  Dim strFile As String
  Dim strFolder As String
  Dim strFindText As String
  Dim strReplaceText As String

  '  Pop up input boxes for user to enter folder path, the finding and replacing texts.
  strFolder = InputBox("C:\Users\freil\AppData\Local\Packages\Microsoft.MicrosoftEdge_8wekyb3d8bbwe\TempState\Downloads\Agreements Folder:")
  strFile = Dir(strFolder & "\" & "*.docx", vbNormal)
  strFindText = InputBox("Find:")
  strReplaceText = InputBox("Replace:")

  '  Open each file in the folder to search and replace texts. Save and close the file after the action.
  While strFile <> ""
    Set objDoc = Documents.Open(FileName:=strFolder & "\" & strFile)
    With objDoc
      With Selection
        .HomeKey Unit:=wdStory
        With Selection.Find
          .Text = strFindText
          .Replacement.Text = strReplaceText
          .Forward = True
          .Wrap = wdFindContinue
          .Format = False
          .MatchCase = False
          .MatchWholeWord = False
          .MatchWildcards = False
          .MatchSoundsLike = False
          .MatchAllWordForms = False
        End With
        Selection.Find.Execute Replace:=wdReplaceAll
      End With
      objDoc.Save
      objDoc.Close
      strFile = Dir()
    End With
  Wend
End Sub

Answer 1

Попробуйте что-нибудь вроде:

Sub BulkFindReplace()
Application.ScreenUpdating = False
Dim Doc As Document, strFolder As String, strFile As String, i As Long
Const FList As String = "One,Two,Three"
Const RList As String = "Four,Five,Six"
StrFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
'Loop through all documents in the chosen folder
While strFile <> ""
  Set Doc = Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With Doc
    With .Range.Find
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      'Process each word from the Find/Replace Lists
      For i = 0 To UBound(Split(FList, ","))
        .Text = Split(FList, ",")(i)
        .Replacement.Text = Split(RList, ",")(i)
        .Execute Replace:=wdReplaceAll
      Next
    End With
    .Close SaveChanges:=True
  End With
  strFile = Dir()
Wend
Set Doc = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
    Dim oFolder As Object
    GetFolder = ""
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
    If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
    Set oFolder = Nothing
End Function

Answer 2

Добро пожаловать на SO. Вам просто нужно охватить цикл While strFile <> "" (и связанные с ним переменные и т. Д.) Из кода 2 вокруг цикла 1 кода. Однако есть другие проблемы с кодом. Может попробовать

Sub FindAndReplaceMultiItems()
  Dim strFindText As String
  Dim strReplaceText As String
  Dim nSplitItem As Long, i As Long
  Dim strFolder As String, StrFile As String
  Dim objDoc As Document
  'Application.ScreenUpdating = False

    With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
        If .Show = -1 Then
        strFolder = .SelectedItems(1)
        End If
    End With

    If Len(strFolder) = 0 Then
    MsgBox " No folder Selected"
    Exit Sub
    End If

  strFindText = InputBox("Enter items to be found here,seperated by comma: ", "Items to be found", "asdf,qwert,zxc")
    If Len(strFindText) = 0 Then
    MsgBox " No Find Text Entered"
    Exit Sub
    End If


  strReplaceText = InputBox("Enter new items here, seperated by comma: ", "New items", "0000000000,1111111111,222222222222")

    If Len(strReplaceText) = 0 Then
    MsgBox " No Replace Text Entered"
    Exit Sub
    End If

  nSplitItem = UBound(Split(strFindText, ","))
      If nSplitItem <> UBound(Split(strReplaceText, ",")) Then
      MsgBox " Unequal Numbers of Find & Replacement Text"
      Exit Sub
      End If

  StrFile = Dir(strFolder & "\" & "*.docx", vbNormal)
    'Open each file in the folder to search and replace texts. Save and close the file after the action.
    While StrFile <> ""
    Set objDoc = Documents.Open(FileName:=strFolder & "\" & StrFile)
    objDoc.Select

      ' Find each item and replace it with new one respectively.
        For i = 0 To nSplitItem
            With Selection
            .HomeKey Unit:=wdStory
                With .Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Text = Split(strFindText, ",")(i)
                .Replacement.Text = Split(strReplaceText, ",")(i)
                .Format = False
                .MatchWholeWord = False
                .Execute Replace:=wdReplaceAll
                End With
            End With
        Next i
     'objDoc.Save
     objDoc.Close True
     StrFile = Dir()
    Wend
'Application.ScreenUpdating = True
End Sub