需要幫助組合 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

歡迎來到 SO。 您只需要在代碼 1 For 循環周圍包含來自代碼 2 的While strFile <> ""循環（和相關變量等）。 但是，代碼還有其他問題。 可以試試

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

Answer 2

嘗試一些類似的東西：

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