批量查找和替换包括子文件夹
Mass Find & Replace including subfolders
我不太了解 VBA 但过去在操作代码方面取得了一些成功。我被这个问题困住了，我试图将两种不同的想法合二为一。我想要做的是大量查找并用弹出框替换 (1) select 或插入路径（包括子文件夹）； (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
提前致谢！
我的意思是这样的：
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
«我需要 pop-up windows，正如我原来 post 中描述的那样。我对这些东西还不够熟悉，无法进行更改» 例如：
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
按照编码，宏将处理 .doc、.docx 和 .docm 文件。要将其限制为 .docx 文件，请将 .doc 引用更改为 .docx。
我不太了解 VBA 但过去在操作代码方面取得了一些成功。我被这个问题困住了，我试图将两种不同的想法合二为一。我想要做的是大量查找并用弹出框替换 (1) select 或插入路径（包括子文件夹）； (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
提前致谢！
我的意思是这样的：
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
«我需要 pop-up windows，正如我原来 post 中描述的那样。我对这些东西还不够熟悉，无法进行更改» 例如：
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
按照编码，宏将处理 .doc、.docx 和 .docm 文件。要将其限制为 .docx 文件，请将 .doc 引用更改为 .docx。