Find and replace in Word a referenced array from Excel - vba

Question

I wrote the following macro to scan through a PPT document and find/replace a range of words on a referenced excel sheet. This works more or less exactly how I'd like it to. I'm now attempting to set this up for use with Word documents as well, but am having some trouble with the "Word" syntax as it differs a bit. Can anyone help me get started here?
Maybe there's a better way to do this - I wrote it in this manner because it allows any user to open the Excel document, click a button, pull up their document and have the macro do its work.
Sub QE_US()
'VARIABLES
Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.presentation
Dim fnd As Variant
Dim rplc As Variant
Dim FindArray As Variant
Dim ReplaceArray As Variant
Dim TxtRng As PowerPoint.TextRange
Dim TmpRng As PowerPoint.TextRange
Dim sld As PowerPoint.Slide
Dim shp As PowerPoint.Shape
Dim objPPT As Object
'PROMPT USER TO OPEN POWERPOINT DOC
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
AppActivate Application.Caption
strFileToOpen = Application.GetOpenFilename _
(Title:="Please Choose PowerPoint for QE - US Conversion")
If strFileToOpen = False Then
MsgBox "No file selected.", vbExclamation, "Sorry!"
GoTo Ending
End If
objPPT.Presentations.Open Filename:=strFileToOpen
'PULLING ARRAY FROM EXCEL
FindArray = Application.Transpose(ThisWorkbook.Worksheets("Conversion").Range("C3:C64"))
ReplaceArray = Application.Transpose(ThisWorkbook.Worksheets("Conversion").Range("B3:B64"))
'LOOP THROUGH EACH SLIDE
For Each sld In objPPT.ActivePresentation.Slides
objPPT.Activate
objPPT.ActiveWindow.View.GotoSlide sld.SlideIndex
For y = LBound(FindArray) To UBound(FindArray)
For Each shp In sld.Shapes
fnd = FindArray(y)
rplc = ReplaceArray(y)
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
Set TxtRng = shp.TextFrame.TextRange.Find(fnd, 0, True, WholeWords:=msoFalse)
If TxtRng Is Nothing Then GoTo NextTxtRng
TxtRng.Select
AppActivate Application.Caption
If MsgBox("Replace " & fnd & " with " & rplc & "?", vbYesNo + vbSystemModal) = vbYes _
Then Set TmpRng = TxtRng.Replace(FindWhat:=fnd, _
ReplaceWhat:=rplc, WholeWords:=False, MatchCase:=True)
End If
End If
'REPLACE OTHER INSTANCES
Do While Not TmpRng Is Nothing
Set TmpRng = TxtRng.Replace(FindWhat:=fnd, _
ReplaceWhat:=rplc, WholeWords:=False, MatchCase:=False)
Loop
'IF TEXT RANGE IS NOTHING (NO VALUE FOUND)
NextTxtRng:
Next shp
Next y
Next sld
AppActivate Application.Caption
MsgBox "QE replaced with US"
'IF NO POWERPOINT SELECTED
Ending:
End Sub
I imagine it can be simplified quite a bit as it's no longer looking through slides, shapes, etc and can just scan the entire document?

Answer 1

Using http://word.mvps.org/faqs/customization/ReplaceAnywhere.htm as a starting point:
Sub ReplaceInWord()
Dim wdApp As New Word.Application, wdDoc As Word.Document, c As Range
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Open("C:\Users\twilliams\Desktop\test.docx")
For Each c In ActiveSheet.Range("C3:C64")
If c.Value <> "" Then
FindReplaceAnywhere wdDoc, c.Value, c.Offset(0, -1).Value
End If
Next c
wdDoc.Close True
End Sub
Public Sub FindReplaceAnywhere(doc As Word.Document, pFindTxt As String, pReplaceTxt As String)
Dim rngStory As Word.Range
Dim lngJunk As Long
Dim oShp As Shape
'Fix the skipped blank Header/Footer problem
lngJunk = doc.Sections(1).Headers(1).Range.StoryType
'Iterate through all story types in the current document
For Each rngStory In doc.StoryRanges
'Iterate through all linked stories
Do
SearchAndReplaceInStory rngStory, pFindTxt, pReplaceTxt
On Error Resume Next
Select Case rngStory.StoryType
Case 6, 7, 8, 9, 10, 11
If rngStory.ShapeRange.Count > 0 Then
For Each oShp In rngStory.ShapeRange
If oShp.TextFrame.HasText Then
SearchAndReplaceInStory oShp.TextFrame.TextRange, _
pFindTxt, pReplaceTxt
End If
Next
End If
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
End Sub
Public Sub SearchAndReplaceInStory(ByVal rngStory As Word.Range, _
ByVal strSearch As String, ByVal strReplace As String)
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = strSearch
.Replacement.Text = strReplace
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
End Sub

Answer 2

Thanks for pointing me in the right direction. Below is the resulting working code.
Sub US_QE_Word()
'VARIABLES
Dim rngXL As Range
Dim x As Range
Dim strFind As String
Dim strReplace As String
Dim rngStory As Object
Dim lngJunk As Long
Dim objWord As Object
'PROMPT USER TO OPEN DOC
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
AppActivate Application.Caption
strFileToOpen = Application.GetOpenFilename _
(Title:="Please Choose File for US - QE Conversion")
If strFileToOpen = False Then
MsgBox "No file selected."
GoTo Ending
End If
objWord.Documents.Open Filename:=strFileToOpen
'FIND/REPLACE
objWord.ActiveDocument.TrackRevisions = True
Set rngXL = ThisWorkbook.Worksheets("List").Range("B3:B80")
For Each rngStory In objWord.ActiveDocument.StoryRanges
For Each x In rngXL
strFind = x.Value
strReplace = x.Offset(0, 1).Value
With rngStory.Find
.Text = strFind
.Replacement.Text = strReplace
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next
Next
AppActivate Application.Caption
MsgBox ("US replaced with QE. Please review changes.")
'IF NO FILE SELECTED
Ending:
End Sub