need help adding to search /replace script 1

[dippncope]

Hello,
I found an almost perfect code for what I need here

http://www.tek-tips.com/viewthread.cfm?qid=1519130

I need to search 1000's of documents for 1-800 phone numbers ( 5 different ones)and change them all to 1 new one. How can I modify this code with either wild cards or by placing all of the old phone numbers and have it search for them and if found change

Dim fs, fil, fldr, strPath
Dim wd

Set fs = CreateObject("Scripting.FileSystemObject")
strPath = InputBox("Enter Path of folder", "Find File")

If strPath = "" Or fs.FolderExists(strPath) = False Then
    MsgBox "Not a valid folder Path.", 64
    'WScript.Quit
End If

Set wd = CreateObject("Word.Application")
wd.Visible = True

Set fldr = fs.GetFolder(strPath)
For Each fil In fldr.Files
    ' If fil.Type = "Microsoft Word Document" Then
If fil.Type = "Microsoft Word 97 - 2003 Document" Then
        
        wd.Documents.Open fil.Path
        
        wd.Selection.Find.ClearFormatting
        With wd.Selection.Find
            .Text = "1-800-111-1111"
            .Forward = True
        End With
        wd.Selection.Find.Execute
        If wd.Selection.Find.Found Then
            wd.Selection.Range = "1-800-222-2222"
        End If
        
        wd.Documents.Close
    End If
Next
wd.Quit

Thanks

 

[jges]

Will this work for you?

Dim fs, fil, fldr, strPath
Dim wd

Set fs = CreateObject("Scripting.FileSystemObject")
strPath = InputBox("Enter Path of folder", "Find File")

If strPath = "" Or fs.FolderExists(strPath) = False Then
    MsgBox "Not a valid folder Path.", 64
    'WScript.Quit
End If

Set wd = CreateObject("Word.Application")
wd.Visible = True

Set fldr = fs.GetFolder(strPath)
For Each fil In fldr.Files
	If fil.Type = "Microsoft Word Document" Then
		wd.Documents.Open fil.Path
		
		wd.Selection.Find.ClearFormatting
		wd.Selection.Find.Replacement.ClearFormatting
		wd.Selection.Find.Execute "<1\-800\-111\-1111>", False, False, True, False, False, True, 1, False, "1-800-222-2222", 2
		wd.Selection.Find.Execute "<1\-800\-333\-3333>", False, False, True, False, False, True, 1, False, "1-800-222-2222", 2
		wd.Selection.Find.Execute "<1\-800\-444\-4444>", False, False, True, False, False, True, 1, False, "1-800-222-2222", 2
		
		wd.Documents.Close
	End If
Next
wd.Quit

The phone numbers with all 1's, 3's, and 4's are the ones you want to replace, the phone number with all 2's is the new (replacement) phone number.

Note I changed the "If fil.Type..." line to reflect what my system was reporting. You may need to change that for your needs.

 

[dippncope]

Thank you very much. That will do exactly what I need.