Formatting replacement text.

[Ladderman451]

I have found a VBA routine off the net for replacing text in multiple documents. I am basically fumbling in the dark as I have a very limited knowledge of VBA. What I want is to have is the replacement text as title case i.e. each word capitalised. I think the function to use is wdTitleWord, but I don't know where to put it. Can anyone help? The code is:

Sub CommandButton1_Click()
Dim MyDialog As FileDialog, GetStr(1 To 100) As String '100 files is the maximum applying this code
On Error Resume Next
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Filters.Clear
.Filters.Add "All WORD File ", "*.doc*", 1
.AllowMultiSelect = True
i = 1
If .Show = -1 Then
For Each stiSelectedItem In .SelectedItems
GetStr(i) = stiSelectedItem
i = i + 1
Next
i = i - 1
End If
Application.ScreenUpdating = False
For j = 1 To i Step 1
Set Doc = Documents.Open(FileName:=GetStr(j), Visible:=True)
Windows(GetStr(j)).Activate
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "????" 'Find What
.Replacement.Text = "?????? ?????" 'Replace With
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Application.Run macroname:="NEWMACROS"
ActiveDocument.Save
ActiveWindow.Close
Next
Application.ScreenUpdating = True
End With
MsgBox "operation end, please view", vbInformation
End Sub

[gmayor]

The following should work, though I don't know what your NEWMACROS macro does, and I would probably have used a different method to get the files.


Option Explicit

Sub CommandButton1_Click()
Dim MyDialog As FileDialog, GetStr(1 To 100) As String '100 files is the maximum applying this code
Dim oDoc As Document
Dim oStory As Range, oRng As Range
Dim i As Long, j As Long
Dim stiSelectedItem As Variant
Const strFindText As String = "the text to find" 'not case sensitive
Const strReplaceText As String = "the replacement text"

On Error GoTo err_Handler
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Filters.Clear
.Filters.Add "All WORD File ", "*.doc*", 1
.AllowMultiSelect = True
i = 1
If .Show = -1 Then
For Each stiSelectedItem In .SelectedItems
GetStr(i) = stiSelectedItem
i = i + 1
Next
i = i - 1
End If
Application.ScreenUpdating = False
For j = 1 To i Step 1
Set oDoc = Documents.Open(FileName:=GetStr(j), Visible:=True)
For Each oStory In oDoc.StoryRanges
Set oRng = oStory
With oRng.Find
Do While .Execute(FindText:=strFindText)
oRng.Text = UCase(strReplaceText)
oRng.Collapse 0
Loop
End With
If oStory.StoryType <> wdMainTextStory Then
While Not (oStory.NextStoryRange Is Nothing)
Set oStory = oStory.NextStoryRange
Set oRng = oStory
With oRng.Find
Do While .Execute(FindText:=strFindText)
oRng.Text = UCase(strReplaceText)
oRng.Collapse 0
Loop
End With
Wend
End If
Next oStory
Application.Run macroname:="NEWMACROS"
oDoc.Close savechanges:=wdSaveChanges
Next
Application.ScreenUpdating = True
End With
MsgBox "operation end, please view", vbInformation
lbl_Exit:
Set oDoc = Nothing
Set oStory = Nothing
Set oRng = Nothing
Exit Sub
err_Handler:
MsgBox Err.Number & vbCr & Err.Description
Err.Clear
GoTo lbl_Exit
End Sub

[Ladderman451]

Thanks for the quick reply. It didn't work at all at first, then I deleted the Application.Run macroname:="NEWMACROS" line then it did the replacements. However, it came out in CAPs, whereas I was hoping for each word to be capitalised with the rest of the word in lower case (Title Case). Any further help you can give me? Thanks in advance.

[gmayor]

It will crash on the NEWMACROS line if the named macro is missing or defective.

As for the Caps - sorry, I thought that was what you wanted. Change the two loops to


Do While .Execute(FindText:=strFindText)
oRng.Text = strReplaceText
oRng.Case = wdTitleWord
oRng.Collapse 0
Loop

If you are trying to capitalise the findtext, delete the two lines

oRng.Text = strReplaceText

[Ladderman451]

Works brilliant! Don't understand it all, but it saves a lot of work rather than doing it document by document. Many thanks for your help.

[gmaxey]

In the future if you don't want a limit, you can make your array dynamic:


Dim MyDialog As FileDialog, arrFiles() As String '***
Dim oDoc As Document
Dim oStory As Range, oRng As Range
Dim lngFile As Long
Dim varItem As Variant
Const strFindText As String = "the text to find" 'not case sensitive
Const strReplaceText As String = "the replacement text"

On Error GoTo err_Handler
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Title = "Select files to process"
.Filters.Clear
.Filters.Add "All WORD File ", "*.doc*", 1
.AllowMultiSelect = True
ReDim Preserve arrFiles(0)'***
If .Show = -1 Then
For Each varItem In .SelectedItems
arrFiles(UBound(arrFiles)) = varItem '***
ReDim Preserve arrFiles(UBound(arrFiles) + 1) '***
Next
End If
ReDim Preserve arrFiles(UBound(arrFiles) - 1) '***
Application.ScreenUpdating = False
For lngFile = 0 To UBound(arrFiles)
Set oDoc = Documents.Open(FileName:=arrFiles(lngFile), Visible:=True)
...
End Sub
[/CODE]

Graham, why did you use Step 1? Just curious.