Go Premium for a chance to win a PS4. Enter to Win

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 2230
  • Last Modified:

Search and replace in multiple files in subfolders

Dear Experts:

below code, which works just fine, performs a search and replace actions on multiple files in a given directory. C:\test\

I would like to run this code on subfolders as well, ie. in the above case, there are several folders under C:\test\, ie.
C:\test\test1,
C:\test\test2,
C:\test\test3,
C:\test\test4,
C:\test\test5

How is the code to be rewritten so that subfolders also get worked on.

Help is much appreciated. Thank you very much in advance.

Regards, Andreas

Sub SearhAndReplace_MultipleFiles()
   Dim strFile As String
   Dim i As Integer
   Dim doc As Document
   Dim rng As Range

    
    Const strFolder = "C:\test\"
    
    strFile = Dir$(strFolder & "*.docx")
    Do Until strFile = ""
        Set doc = Documents.Open(strFolder & strFile)
        
        For Each rng In doc.StoryRanges
        
                    With rng.Find
                        .ClearFormatting
                        .Replacement.ClearFormatting
                        .Text = "Rev. 1.0"
                        .Replacement.Text = "Rev 1.1"
                        .Replacement.Font.Size = 9
                        .Forward = True
                        .Wrap = wdFindContinue
                        .Execute Replace:=wdReplaceAll
                    End With
                Next rng
        doc.Save
        doc.Close
        strFile = Dir$()
    Loop
End Sub

Open in new window

0
AndreasHermle
Asked:
AndreasHermle
  • 3
  • 3
1 Solution
 
Chris BottomleyCommented:
Try:

Option Explicit

Sub SearchAndReplace_MultipleFiles()
Dim fso As Object
Dim ROOT As Object
Dim fldr As Object
    
    Const strFolder = "C:\test\"
    Set fso = CreateObject("scripting.filesystemobject")
    If Not fso.folderexists(strFolder) Then
        MsgBox "Folder '" & strFolder & "' not found - Exiting routine", , "Error"
        Exit Sub
    End If
    Set ROOT = fso.getfolder(strFolder)
    processFolder ROOT.Path
    For Each fldr In ROOT.subfolders
        processFolder fldr.Path
    Next
    
End Sub

Sub processFolder(strFolder As String)
Dim strFile As String
Dim doc As Document
Dim rng As Word.Range


    strFile = Dir$(strFolder & "*.docx")
    Do Until strFile = ""
        Set doc = Documents.Open(strFolder & strFile)
        
        For Each rng In doc.StoryRanges
        
                    With rng.Find
                        .ClearFormatting
                        .Replacement.ClearFormatting
                        .Text = "Rev. 1.0"
                        .Replacement.Text = "Rev 1.1"
                        .Replacement.Font.Size = 9
                        .Forward = True
                        .Wrap = wdFindContinue
                        .Execute Replace:=wdReplaceAll
                    End With
                Next rng
        doc.Save
        doc.Close
        strFile = Dir$()
    Loop
End Sub

Open in new window


Call SearchAndReplace_MultipleFiles, 'improved' the name spelling ;o) and this should do the job


Chris
0
 
AndreasHermleAuthor Commented:
Hi Chris,

thank you very much for your swift support.

I am afraid to tell you that the code does not work.

After hitting 'Do Until strFile = ""' the code does not proceed to the next line but goes straight to 'End Sub'

Any idea why?

Regards, Andreas
0
 
Chris BottomleyCommented:
Apologies limited testing and overlooked sub call change:

Option Explicit

Sub SearhAndReplace_MultipleFiles()
Dim FSO As Object
Dim ROOT As Object
Dim fldr As Object
    
    Const strFolder = "C:\test\"
    Set FSO = CreateObject("scripting.filesystemobject")
    If Not FSO.folderexists(strFolder) Then
        MsgBox "Folder '" & strFolder & "' not found - Exiting routine", , "Error"
        Exit Sub
    End If
    Set ROOT = FSO.getfolder(strFolder)
    processFolder ROOT.Path
    For Each fldr In ROOT.subfolders
        processFolder fldr.Path
    Next
    
End Sub

Sub processFolder(strFolder As String)
Dim strFile As String
Dim doc As Document
Dim rng As Word.Range
Dim fileSet As Object

    strFile = Dir$(strFolder & "\" & "*.docx")
    Do Until strFile = ""
        Set doc = Documents.Open(strFolder & strFile)
        
        For Each rng In doc.StoryRanges
        
                    With rng.Find
                        .ClearFormatting
                        .Replacement.ClearFormatting
                        .Text = "Rev. 1.0"
                        .Replacement.Text = "Rev 1.1"
                        .Replacement.Font.Size = 9
                        .Forward = True
                        .Wrap = wdFindContinue
                        .Execute Replace:=wdReplaceAll
                    End With
                Next rng
        doc.Save
        doc.Close
        strFile = Dir$()
    Loop
End Sub

Open in new window


i.e. tweaked line 28.

Chris
0
Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
AndreasHermleAuthor Commented:
Hi Chris,

thank you very much for your swift support.

I still get an error message on ...

Set doc = Documents.Open(strFolder &  strFile).

Runtime Error: 5174:
This file was not found:
C:\Test\test1Dok.docx

I guess we are almost there. The insertion of the backslash between the (sub-)folder name and actual file is not performed by the code.

Help is much appreciated. Thank you very much in advance.

Regards, Andreas
0
 
Chris BottomleyCommented:
Unfortunately

1. I do not have relevant files and structuure to edit
2. I'm being an idiot!

This should resolve the issue properly

Sub SearhAndReplace_MultipleFiles()
Dim FSO As Object
Dim ROOT As Object
Dim fldr As Object
    
    Const strFolder = "C:\test\"
    Set FSO = CreateObject("scripting.filesystemobject")
    If Not FSO.folderexists(strFolder) Then
        MsgBox "Folder '" & strFolder & "' not found - Exiting routine", , "Error"
        Exit Sub
    End If
    Set ROOT = FSO.getfolder(strFolder & "\")
    processFolder ROOT.Path
    For Each fldr In ROOT.subfolders
        processFolder fldr.Path & "\"
    Next
    
End Sub

Sub processFolder(strFolder As String)
Dim strFile As String
Dim doc As Document
Dim rng As Word.Range
Dim fileSet As Object

    strFile = Dir$(strFolder & "*.docx")
    Do Until strFile = ""
        Set doc = Documents.Open(strFolder & strFile)
        
        For Each rng In doc.StoryRanges
        
                    With rng.Find
                        .ClearFormatting
                        .Replacement.ClearFormatting
                        .Text = "Rev. 1.0"
                        .Replacement.Text = "Rev 1.1"
                        .Replacement.Font.Size = 9
                        .Forward = True
                        .Wrap = wdFindContinue
                        .Execute Replace:=wdReplaceAll
                    End With
                Next rng
        doc.Save
        doc.Close
        strFile = Dir$()
    Loop
End Sub

Open in new window

0
 
AndreasHermleAuthor Commented:
Hi Chris,

really a great job! Thank you very much for your great support. This macro will save me hours of valuable time. I am so glad!

This is a great forum!
0

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 3
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now