Replace text in word file in all sub folders - vba

I am putting together a VBA macro that:
1.reads a folder
2.creates a collection of all its subfolders
3.loops through all the subfolders and find any word document ending in .doc
4.in each .doc file: replace a bit of text and save then close the documents.
This macro doesn't work correctly: it doesn't replace the text in any word documents in the subfolders.
It doesn't actual open any word document, I am unsure wether it should open each word doc one after another or if it runs in the background.
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
' Parent folder including trailing backslash
'YOU MUST EDIT THIS.
strFolder = "G:\2009\09771\Design\ESD\Commercial Tower KSD1\Green Star As Built\Round 1 Submission - Draft\02. Indoor Environment Quality"
' Loop through the subfolders and fill Collection object
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 word docs in subfolder
'YOU MUST EDIT THIS if you want to change the files extension
strFile = Dir(strFolder & varItem & "*.doc")
Do While strFile <> ""
Set file = Documents.Open(FileName:=strFolder & _
varItem & "\" & strFile)
' Start of macro 1replace text GS-XXXAB with GS-1624AB
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Application.WindowState = wdWindowStateNormal
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "GS-XXXAB "
.Replacement.Text = "GS-1624AB "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
' End of macro 1
' Saves the file
ActiveDocument.Save
ActiveDocument.Close
' set file to next in Dir
strFile = Dir
Loop
Next varItem
End Sub

Your code worked for me with below changes
From
strFile = Dir(strFolder & varItem & "*.doc")
To
strFile = Dir(strFolder & varItem & "\" & "*.doc")
Make sure the path for folder is correct in strFolder Variable. Eg( strFolder = "C:\Users\Santosh\Desktop\tes\")

Related

Find and replace word VBA macro to search folder and subfolders

I currently have this VBA macro that can search through a single folder for docx files and run find and replace in headers and footers. I am new to VBA and just good and manipulations of code, and was wondering how I can could modify this one to add in the ability to search subfolders as well?
Sub FindAndReplaceInFolder()
Dim objDoc As Document
Dim strFile As String
Dim strFolder As String
Dim strFindText As String
Dim strReplaceText As String
Dim xSelection As Selection
Dim xSec As Section
Dim xHeader As HeaderFooter
Dim xFooter As HeaderFooter
' 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
For Each xSec In objDoc.Sections
For Each xHeader In xSec.Headers
xHeader.Range.Select
Set xSelection = objDoc.Application.Selection
With xSelection
.HomeKey Unit:=wdStory
With xSelection.Find
.Text = strFindText
.Replacement.Text = strReplaceText
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
xSelection.Find.Execute Replace:=wdReplaceAll
End With
Next xHeader
For Each xFooter In xSec.Footers
xFooter.Range.Select
Set xSelection = objDoc.Application.Selection
With xSelection
.HomeKey Unit:=wdStory
With xSelection.Find
.Text = strFindText
.Replacement.Text = strReplaceText
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
xSelection.Find.Execute Replace:=wdReplaceAll
End With
Next xFooter
Next xSec
objDoc.Save
objDoc.Close
strFile = Dir()
End With
Wend
End Sub
Not sure how to get started with this so looking for some help

Mass Find & Replace including subfolders

I don't really know VBA but have had some success with manipulating code in the past. I'm getting stuck with this one, where I tried to mix 2 different ideas into one. What I want to do is a mass find & replace with pop-up boxes to (1) select or insert the path (that includes subfolders); (2) insert the "find text"; (3) insert the "replace text"; and (4) cycle through all .docx files in all subfolders.
I found this code to do what I want on a single folder, but can't figure out how to manipulate it to include subfolders:
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
Thanks in advance!
I mean something like this:
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
Output:
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
«I need pop-up windows as described in my original post. I'm not familiar enough with this stuff to make changes» For example:
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
As coded, the macro will process .doc, .docx, and .docm files. To limit it to .docx files, change the .doc reference to .docx.

How to find and replace a text in multiple Word documents using VBA

I am seeking help to find and replace texts in multiple Word documents. I have a code to do that in only one document but don't know how to loop through all documents in the same folder.
Here is the code:
Sub storyrangesearch()
For Each myStoryRange In ActiveDocument.StoryRanges
With myStoryRange.Find
.Text = " Of "
.Replacement.Text = " of "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = True
.MatchByte = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
Next myStoryRange
End Sub
For example:
Sub Demo()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
With .Range.Find
.Text = " Of "
.Replacement.Text = " of "
.Format = False
.Forward = True
.MatchCase = True
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
.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
To extend the processing to sub-folders, see: https://www.msofficeforums.com/117894-post9.html

Error when inserting image using variable for Selection.InlineShapes.AddPicture

I am trying to go through a word document, and replace existing image path strings with the actual image. When I enter the address hard coded, it works. But if I put the same code in a variable I get an error
Error:
Run-time error '5152':
This is not a valid file name.
Try one or more of the following:
* Check the path to make sure it was typed correctly,
* Select a file from the list of files and folders.
Code:
Sub InsertJPGs()
For Each singleLine In ActiveDocument.Paragraphs
Dim Value As Variant
Dim imageName As String
Options.DefaultFilePath(wdDocumentsPath) = "d:\Downloads\ReportImages\"
originalLineText = singleLine.Range.Text
lineText = singleLine.Range.Text
If InStr(lineText, ".jpg") <> 0 Then
singleLine.Range.Select
rangeText = singleLine.Range.Text
imageName = rangeText
imageName = "D:\Downloads\ReportImages\" & rangeText
'imageName = "D:\Downloads\ReportImages\PictureImportTest_ATTICSkylight#1#_img2.jpg"
Selection.InlineShapes.AddPicture FileName:= _
imageName, LinkToFile:=True, SaveWithDocument:=True
End If
If InStr(lineText, "[[[IMAGE LIST]]]") <> 0 Then
Exit For
End If
Next singleLine
End Sub
Try:
Sub Demo()
Application.ScreenUpdating = False
Dim FlNm As String: Const StrPath As String = "d:\Downloads\ReportImages\"
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "<[! ^t^l^13]#.[Jj][Pp][Gg]>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
FlNm = .Duplicate.Text
.Text = vbNullString
.InlineShapes.AddPicture StrPath & FlNm, False, True, .Duplicate
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub
If you want to retain the filenames in the document, delete or comment out:
.Text = vbNullString

Need Help Combining 2 VBA codes

I need to combine these two VBA Codes the first is finding and replacing multi items in one document and the second find and replaces a word throughout an entire folder. As you can imagine I need to find and replace multiple words in each document in the folder with 1 button.
CODE 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
CODE 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
Welcome to SO. You just need to encompass While strFile <> "" loop (and related variables etc) from Code 2 around Code 1 For loop. However there are other issues with code. May try
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
Try something along the lines of:
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