群众发现＆amp;替换包括子文件夹

Question

我真的不知道VBA，但是过去处理代码方面取得了一些成功。我被这一问题陷入困境，在那里我试图将2个不同的想法混合在一起。我想做的是大众发现＆amp;用弹出框替换为（1）选择或插入路径（包括子文件夹）； （2）插入“查找文本”； （3）插入“替换文本”； （4）循环浏览所有子文件夹中的所有.docx文件。

我发现此代码可以在单个文件夹上执行我想要的操作，但是不知道如何操纵它以包括子文件夹：

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("Enter folder path here:")
  strFile = Dir(strFolder & "\" & "*.docx", vbNormal)
  strFindText = InputBox("Enter finding text here:")
  strReplaceText = InputBox("Enter replacing text here:")
 
  '  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

我的意思是这样：

Option Explicit

Sub FindAndReplaceInFolder()
    Dim colFiles As Collection, f
    Dim strFolder As String, strFindText As String, strReplaceText As String
    
    'Pop up input boxes for user to enter folder path, the finding and replacing texts.
    '(fixed values for testing...)
    strFolder = "C:\Temp\SO\"        'InputBox("Enter folder path here:")
    strFindText = "several"          'InputBox("Enter finding text here:")
    strReplaceText = "three or four" 'InputBox("Enter replacing text here:")
    
    Set colFiles = GetMatches(strFolder, "*.docx")
    For Each f In colFiles
        Debug.Print "Processing: " & f
        ReplaceInFile CStr(f), strFindText, strReplaceText
    Next f
    Debug.Print "Processed " & colFiles.Count & " files"
End Sub

'replace all instances of `strFindText` with `strReplaceText` in file at `fPath`
Sub ReplaceInFile(fPath As String, strFindText As String, strReplaceText As String)
    Dim doc As Document
    Set doc = Documents.Open(fPath)
    With doc.Content.Find
        .Text = strFindText
        .Replacement.Text = strReplaceText
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
    End With
    doc.Close savechanges:=True
End Sub

'Return a collection of file paths given a starting folder and a file pattern
'  e.g. "*.docx"
'Pass False for last parameter if don't want to check subfolders
Function GetMatches(startFolder As String, filePattern As String, _
                    Optional subFolders As Boolean = True) As Collection
    Dim fso, fldr, f, subFldr, fPath
    Dim colFiles As New Collection
    Dim colSub As New Collection
    
    Set fso = CreateObject("scripting.filesystemobject")
    colSub.Add startFolder
    
    Do While colSub.Count > 0
        Set fldr = fso.getfolder(colSub(1))
        colSub.Remove 1
        If subFolders Then
            For Each subFldr In fldr.subFolders
                colSub.Add subFldr.Path
            Next subFldr
        End If
        fPath = fldr.Path
        If Right(fPath, 1) <> "\" Then fPath = fPath & "\"
        f = Dir(fPath & filePattern) 'Dir is faster...
        Do While Len(f) > 0
            colFiles.Add fPath & f
            f = Dir()
        Loop
    Loop
    Set GetMatches = colFiles
End Function

输出：

Processing: C:\Temp\SO\tester - Copy (2).docx
Processing: C:\Temp\SO\tester - Copy - Copy.docx
Processing: C:\Temp\SO\tester - Copy.docx
Processing: C:\Temp\SO\tester.docx
Processing: C:\Temp\SO\blah\tester - Copy (2).docx
Processing: C:\Temp\SO\blah\tester - Copy - Copy.docx
Processing: C:\Temp\SO\blah\tester - Copy.docx
Processing: C:\Temp\SO\blah\tester.docx
Processed 8 files

Answer 2

«我需要原始帖子中所述的弹出窗口。 不太熟悉以进行更改»

Option Explicit
Dim FSO As Object, oFolder As Object, StrFolds As String, StrFnd As String, StrRep As String
 
Sub Main()
Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
StrFnd = InputBox("Enter finding text here:")
If StrFnd = "" Then Exit Sub
StrRep = InputBox("Enter replacing text here:")
TopLevelFolder = GetFolder
If TopLevelFolder = "" Then Exit Sub
StrFolds = vbCr & TopLevelFolder
If FSO Is Nothing Then
  Set FSO = CreateObject("Scripting.FileSystemObject")
End If
'Get the sub-folder structure
Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders
For Each aFolder In TheFolders
  RecurseWriteFolderName (aFolder)
Next
'Process the documents in each folder
For i = 1 To UBound(Split(StrFolds, vbCr))
  Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i)))
Next
End Sub
 
 
Sub RecurseWriteFolderName(aFolder)
Dim SubFolders As Variant, SubFolder As Variant
Set SubFolders = FSO.GetFolder(aFolder).SubFolders
StrFolds = StrFolds & vbCr & CStr(aFolder)
On Error Resume Next
For Each SubFolder In SubFolders
  RecurseWriteFolderName (SubFolder)
Next
End Sub


Sub UpdateDocuments(oFolder As String)
Application.ScreenUpdating = False
Dim strInFolder As String, strFile As String, wdDoc As Document
strInFolder = oFolder
strFile = Dir(strInFolder & "\*.doc", vbNormal)
While strFile <> ""
  Set wdDoc = Documents.Open(FileName:=strInFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    With .Range.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Text = StrFnd
      .Replacement.Text = StrRep
      .Execute Replace:=wdReplaceAll
    End With
    'Save and close the document
    .Close SaveChanges:=True
  End With
  strFile = Dir()
Wend
Set wdDoc = 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

我对这些东西 要将其限制为.docx文件，请将.doc引用更改为.docx。