Condensing code

[Chunk]

I have a userform that allows the user to print various word documents. Before it prints the word document the program runs a find and replace routine on the document. Everything works fine. The problem is the code is the same for each document, minus the doc name and location, and BULKY. I was wondering if there was a way to condense the code, so I only had to write the repeating part once? Here is the code I have for each document (The user has access to over 50 documents)
Thank you in advance for any help.

Chunk



Public Sub FindAndReplace_Brief()

Dim wrdApp As Object
Dim wrdNNDF As Object

Set wrdApp = CreateObject("Word.Application")
Set wrdNNDF = wrdApp.Documents.Open("C:\BriefHist_sheet.docx")
'CU Phase Title
wrdNNDF.Activate
'wrdApp.Visible = True
wrdApp.Selection.Find.ClearFormatting
wrdApp.Selection.Find.Replacement.ClearFormatting
With wrdApp.Selection.Find
.Text = "XXX"
.Replacement.Text = tbox_CUTitle.Text
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
wrdApp.Selection.Find.Execute Replace:=wdReplaceAll
'Job Order
With wrdApp.Selection.Find
.Text = "YYY"
.Replacement.Text = tbox_JO.Text
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
wrdApp.Selection.Find.Execute Replace:=wdReplaceAll
'Key Op
With wrdApp.Selection.Find
.Text = "ZZZ"
.Replacement.Text = tbox_KO.Text
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
wrdApp.Selection.Find.Execute Replace:=wdReplaceAll
wrdNNDF.PrintOut
wrdNNDF.Close SaveChanges:=wdDoNotSaveChanges
wrdApp.Quit
End Sub

[gmayor]

You could add a parameter to the macro and call the macro with the document name. That way you only need one main code which you can call as required. e.g.


Option Explicit

Public Sub ProcessDocument()
FindAndReplace_Brief "C:\BriefHist_sheet.docx"
End Sub


Public Sub FindAndReplace_Brief(strFullName As String)
Dim wrdApp As Object
Dim wrdNNDF As Object

Set wrdApp = CreateObject("Word.Application")
Set wrdNNDF = wrdApp.Documents.Open(strFullName)
'CU Phase Title
wrdNNDF.Activate
'wrdApp.Visible = True
wrdApp.Selection.Find.ClearFormatting
wrdApp.Selection.Find.Replacement.ClearFormatting
With wrdApp.Selection.Find
.Text = "XXX"
.Replacement.Text = tbox_CUTitle.Text
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
wrdApp.Selection.Find.Execute Replace:=wdReplaceAll
'Job Order
With wrdApp.Selection.Find
.Text = "YYY"
.Replacement.Text = tbox_JO.Text
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
wrdApp.Selection.Find.Execute Replace:=wdReplaceAll
'Key Op
With wrdApp.Selection.Find
.Text = "ZZZ"
.Replacement.Text = tbox_KO.Text
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
wrdApp.Selection.Find.Execute Replace:=wdReplaceAll
wrdNNDF.PrintOut
wrdNNDF.Close SaveChanges:=wdDoNotSaveChanges
wrdApp.Quit
End Sub

[Chunk]

gmayor,

How would that work if I have multiple documents that need to be printed (ie BriefHist_sheet.docx, Example1.docx, Example2.docx, Example3.docx)?

[SamT]

To allow the user to pick files to process in a batch

Sub FilePicker()
'Opens a Dialog box, allows User to select multiple files
'to feed to Sub FindAndReplace_Brief for processing.
'
'For help, see: http://www.vbaexpress.com/forum/showthread.php?53869-Condensing-code

Dim FP As FileDialog
Dim FName As Variant

Set FP = Application.FileDialog( _
FileDialogType:=msoFileDialogFilePicker)
With FP
.AllowMultiSelect = True
If .Show = 0 Then Exit Sub
End With

For Each FName In FP.SelectedItems
FindAndReplace_Brief FName
Next FName

Set FP = Nothing
End Sub
You can make FindAndReplace_Brief shorter by use a "Find" Array and a Replacement" array

FindWhat = Array("XXX", "YYY", "ZZZ")
ReplaceWith = Array(tbox_CUTitle.Text, tbox_JO.Text, tbox_KO.Text)

For i = 0 To 2
With wrdApp.Selection.Find
.Text = FindWhat(i)
.Replacement.Text = ReplaceWith(i)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
wrdApp.Selection.Find.Execute Replace:=wdReplaceAll
Next i

[Chunk]

Thanks gmayor and SamT,

I ended up using the array format to handle the Find and Replace. It works beautifully and definitely makes the code a tad bit easier to read through. Thanks again.

Chunk