Find and Replace whole folder content

Leslie · #1 03-01-2020, 10:28 AM

Much pretty sure about getting solution from this forum!

Got a code, and the code needs execution so that the pointed folder, containing Word files, completely 'Find and Replace' the files' content in whole.

Much obliged if the below code gets optimized too (quick execution)!
Below is the F/R code:

Code:

Sub FindAndReplaceMultiItems()
  Dim strFindText As String
  Dim strReplaceText As String
  Dim nSplitItem As Long
   
  Application.ScreenUpdating = False

  strFindText = "northenn,westenn"
  strReplaceText = "northern,western"
  
  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

MsgBox "DONE EXECUTION"
End Sub

Thanks.

macropod · #2 03-01-2020, 03:11 PM

See, for example: https://www.msofficeforums.com/45854-post2.html

Leslie · #3 03-01-2020, 08:07 PM

Quote:

Originally Posted by macropod

See, for example: https://www.msofficeforums.com/45854-post2.html

Greatly appreciate your response.

However, 5 out of 6 files of the folder never get updated (except the opened *.docx file) and that too not saved automatically after being run (seeing it manual save works).

Any help, much appreciated.

Code:

Sub FindReplaceAllFilesInFolder()
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
      Call FnR
      .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


Sub FnR()
  Dim strFindText As String
  Dim strReplaceText As String
  Dim nSplitItem As Long
   
  Application.ScreenUpdating = False

  strFindText = "northenn,westenn"
  strReplaceText = "northern,western"
  
  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

MsgBox "DONE EXECUTION"
End Sub

macropod · #4 03-01-2020, 08:09 PM

So how have you implemented the code? Without seeing you implementation, it's impossible to know what the issue is.

Leslie · #5 03-01-2020, 08:13 PM

Quote:

Originally Posted by macropod

So how have you implemented the code? Without seeing you implementation, it's impossible to know what the issue is.

Now the implemented code is updated below:

Code:

Sub FindReplaceAllFilesInFolder()
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
      Call FnR
      .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


Sub FnR()
  Dim strFindText As String
  Dim strReplaceText As String
  Dim nSplitItem As Long
   
  Application.ScreenUpdating = False

  strFindText = "northenn,westenn"
  strReplaceText = "northern,western"
  
  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

MsgBox "DONE EXECUTION"
End Sub

Leslie · #6 03-01-2020, 08:26 PM

Quote:

Originally Posted by Leslie

Now the implemented code is updated below:

Code:

Sub FindReplaceAllFilesInFolder()
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
      Call FnR
      .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


Sub FnR()
  Dim strFindText As String
  Dim strReplaceText As String
  Dim nSplitItem As Long
   
  Application.ScreenUpdating = False

  strFindText = "northenn,westenn"
  strReplaceText = "northern,western"
  
  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

MsgBox "DONE EXECUTION"
End Sub

Please let me know any wrong/inappropriate code added, if any, from my end!

macropod · #7 03-01-2020, 08:29 PM

OK, aside from the issue that I very much doubt your original code came from the forum, you can't use 'Selection' objects when (as the macro in the link does) the document being opened for processed remains invisible. The consequence of using your code the way you've done is that only the document containing the code gets processed. A simple approach is to use:

Code:

Sub FindReplaceAllFilesInFolder()
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
      Call FnR(.Range)
      .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

Sub FnR(Rng As Range)
Dim strFindText As String, strReplaceText As String, nSplitItem  As Long
strFindText = "northenn,westenn"
strReplaceText = "northern,western"
With Rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Forward = True
  .Format = False
  .MatchCase = False
  .MatchWholeWord = False
  .Wrap = wdFindContinue
  For nSplitItem = 0 To UBound(Split(strFindText, ","))
    .Text = Split(strFindText, ",")(nSplitItem)
    .Replacement.Text = Split(strReplaceText, ",")(nSplitItem)
    .Execute Replace:=wdReplaceAll
  Next
End With
End Sub

Leslie · #8 03-01-2020, 08:58 PM

Code:

Sub FnR(Rng As Range)
Dim strFindText As String, strReplaceText As String, nSplitItem  As Long
strFindText = "northenn,westenn"
strReplaceText = "northern,western"
With Rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Forward = True
  .Format = False
  .MatchCase = False
  .MatchWholeWord = False
  .Wrap = wdFindContinue
  For nSplitItem = 0 To UBound(Split(strFindText, ","))
    .Text = Split(strFindText, ",")(nSplitItem)
    .Replacement.Text = Split(strReplaceText, ",")(nSplitItem)
    .Execute Replace:=wdReplaceAll
  Next
End With
End Sub

Replaced 'Replace' with 'strReplaceText' in the above code (executes fine now).

Perfect code!

Thanks dear Paul Edstein @macropod.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Static Folder Locations to Automate a Find and Replace using Word VBA	rmoyar	Word VBA	9	01-29-2020 02:35 PM
Need to find/replace text in many word files - but text is in embedded word files	semple.13	Word VBA	5	11-03-2015 01:20 PM
Find & replace footer text in a folder of Word 2010 documents	kennethc	Word	3	03-28-2015 02:49 AM
VBA Batch Find & Replace for all MSOffice extensions, to replace File Name and Content of the File	QA_Compliance_Advisor	Word VBA	11	09-11-2014 11:51 PM
Macro to replace SSN in all files within a folder	caj1980	Word VBA	7	09-11-2014 04:17 PM