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
Related
I would like to apply a VBA Macro to multiple docx files. My macro find a text with a specific font and then hide it.
This is the macro that works when you execute it on a single docx file :
Sub color()
Dim Rng As Range
Dim Fnd As Boolean
G:
Set Rng = ActiveDocument.Range
Rng.Find.ClearFormatting
Rng.Find.Font.color = RGB(191, 191, 191)
Rng.Find.Replacement.ClearFormatting
With Rng.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
Fnd = .Found
End With
If Fnd = True Then
With Rng
.MoveStart wdWord, 0
.Select
With .Font
.Hidden = True
End With
End With
GoTo G
End If
End Sub
And I've found a macro on a forum that can loop on all files in a folder and I've combined to mine :
Sub Documentos()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
strDocNm = ActiveDocument.FullName: strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.docx", vbNormal)
While strFile <> ""
If strFolder & "\" & strFile <> strDocNm Then
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
Dim Rng As Range
Dim Fnd As Boolean
G:
Set Rng = ActiveDocument.Range
Rng.Find.ClearFormatting
Rng.Find.Font.color = RGB(191, 191, 191)
Rng.Find.Replacement.ClearFormatting
With Rng.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
Fnd = .Found
End With
If Fnd = True Then
With Rng
.MoveStart wdWord, 0
.Select
With .Font
.Hidden = True
End With
End With
GoTo G
End If
.Close SaveChanges:=True
End With
End If
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
When I execute this macro, I opens the document but does nothing.
Can someone help to combine them ?
I guess it's because of Set Rng = ActiveDocument.Range. in the loop you set Rng to active document. open a file doesn't make it activated automatically. And I see you have already assigned the opened file to wdDoc. Maybe use 'Set Rng = .Range' instead. see if it works for you.
Use the tools already built into Word.
A much simpler route to do that same effect is to create a Word character style with gray shading and apply that to all text that is to have a grey background. Then you can change all instances to a clear background by simply changing the style definition:
Sub ChangeShadedTextStyle()
ActiveDocument.Styles("Shaded Text").Font.Shading.BackgroundPatternColor = wdColorAutomatic
End Sub
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
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
I am a novice at this but I convert .RTF files in a whole folder to .DOCX files using this code below.
Sub BatchConvertToDocx()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.rtf", vbNormal)
While strFile <> ""
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
.SaveAs2 FileName:=Left(.FullName, InStrRev(.FullName, ".")) & "docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
.Close wdDoNotSaveChanges
End With
strFile = Dir()
Wend
Set wdDoc = Nothing
App
lication.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
Could somebody please tell me how to hide text that is between square braces in the output .docx file?
For example
Hi [This is the text that should be hidden] there.
Also, while converting the .docx file back to .rtf file, the text should reappear in the output .rtf file.
I see 2 different ways to do this.
Hard remove/delete the text with find/replace. Here I see no possibility to bring that text back in any way. Gone is gone.
Hide the text from printing with formatting it as hidden text.
Hard Remove
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "\[*\]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
Hide from printing
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Font.Hidden = True
With Selection.Find
.Text = "\[*\]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
'if this line is not used the text might be visible on the screen but not on print.
ActiveWindow.ActivePane.View.ShowAll = False
Unhiding the text from printing
This should un hide the text when converting back to .rtf
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Font.Hidden = True
Selection.Find.Replacement.Font.Hidden = False
With Selection.Find
.Text = "\[*\]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
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\")