Time Sensitive Request! Open, Find + Replace Text, Save, And Close For Multiple Files

[wakruger]

Help!!! I was just asked to find and replace the same two words on the last slide in 280 PowerPoint files, and the changes need to be done in the next day or two. :crying: Can someone please help me develop one macro that will do the following:

1) Open the files in the folder
2) Find and replace the two words (let's use Joe Smith replaced with Bob Jones)
3) Save the files to the same folder (If it makes any difference, right now the files are .pptx, and I know they'll need to be .pptm for the macro to work)
4) Close the files

I'll start making the changes manually now since there's a deadline, but hopefully a kind soul out there will quickly come to my rescue with an automated way to do this!

[John Wilson]

Can the presentations all be placed in a single folder?
Are the two words separate or is it a "phrase" i.e "Joe Bloggs" or "Joe and Mr Bloggs"?
Are the words in a normal textbox or a placeholder (please say if you don't know the difference)?

The presentations do not need to be a pptm BTW.

This is the basic code but take note of the warning and work on copies of the files!!


Sub EveryPresentationInFolder()

Dim sFolder As String
Dim sFileSpec As String
Dim sFileName As String
Dim oPres As Presentation
Dim osld As Slide
Dim oshp As Shape
Dim FindThis As String
Dim ReplaceWith As String
' CAREFUL your files will be overwritten!
' MAKE A COPY OF THE FILES AND PUT IN A FOLDER ON THE DESKTOP CALLED Files


'change these
FindThis = "Joe Bloggs"
ReplaceWith = "Fred Carney"
sFolder = Environ("USERPROFILE") & "\Desktop\Files\"

sFileSpec = "*.PPTX"


sFileName = Dir$(sFolder & sFileSpec)


While sFileName <> ""
Set oPres = Presentations.Open(sFolder & sFileName, msoFalse)
Set osld = oPres.Slides(oPres.Slides.Count) 'last slide
For Each oshp In osld.Shapes
If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then
oshp.TextFrame.TextRange = Replace(oshp.TextFrame.TextRange, FindThis, ReplaceWith)
End If
End If
Next oshp
oPres.Save
oPres.Close
Set oPres = Nothing
sFileName = Dir()
Wend


End Sub

[wakruger]

Can the presentations all be placed in a single folder?
Are the two words separate or is it a "phrase" i.e "Joe Bloggs" or "Joe and Mr Bloggs"?
Are the words in a normal textbox or a placeholder (please say if you don't know the difference)?

The presentations do not need to be a pptm BTW.



Thanks for the response! The two words are right next to each other. I am pretty sure the text is in the placeholder box, but I didn't create the files. Is there a way to tell?

I can definitely make copies of all the files and put them in a folder on my desktop.

[John Wilson]

The code I posted should work. This slight variation that opens each file without a window might be slightly quicker.


Sub EveryPresentationInFolder()

Dim sFolder As String
Dim sFileSpec As String
Dim sFileName As String
Dim oPres As Presentation
Dim osld As Slide
Dim oshp As Shape
Dim FindThis As String
Dim ReplaceWith As String
' CAREFUL your files will be overwritten!
' MAKE A COPY OF THE FILES AND PUT IN A FOLDER ON THE DESKTOP CALLED Files


'change these
FindThis = "Joe Bloggs"
ReplaceWith = "Fred Carney"
sFolder = Environ("USERPROFILE") & "\Desktop\Files\"

sFileSpec = "*.PPTX"


sFileName = Dir$(sFolder & sFileSpec)


While sFileName <> ""
Set oPres = Presentations.Open(FileName:=sFolder & sFileName, _
ReadOnly:=msoFalse, _
WithWindow:=msoFalse)
Set osld = oPres.Slides(oPres.Slides.Count) 'last slide
For Each oshp In osld.Shapes
If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then
oshp.TextFrame.TextRange = Replace(oshp.TextFrame.TextRange, FindThis, ReplaceWith)
End If
End If
Next oshp
oPres.Save
oPres.Close
Set oPres = Nothing
sFileName = Dir()
Wend


End Sub

I would start with maybe 6 files to update as a test

[wakruger]

The code I posted should work. This slight variation that opens each file without a window might be slightly quicker.


Sub EveryPresentationInFolder()

Dim sFolder As String
Dim sFileSpec As String
Dim sFileName As String
Dim oPres As Presentation
Dim osld As Slide
Dim oshp As Shape
Dim FindThis As String
Dim ReplaceWith As String
' CAREFUL your files will be overwritten!
' MAKE A COPY OF THE FILES AND PUT IN A FOLDER ON THE DESKTOP CALLED Files


'change these
FindThis = "Joe Bloggs"
ReplaceWith = "Fred Carney"
sFolder = Environ("USERPROFILE") & "\Desktop\Files\"

sFileSpec = "*.PPTX"


sFileName = Dir$(sFolder & sFileSpec)


While sFileName <> ""
Set oPres = Presentations.Open(FileName:=sFolder & sFileName, _
ReadOnly:=msoFalse, _
WithWindow:=msoFalse)
Set osld = oPres.Slides(oPres.Slides.Count) 'last slide
For Each oshp In osld.Shapes
If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then
oshp.TextFrame.TextRange = Replace(oshp.TextFrame.TextRange, FindThis, ReplaceWith)
End If
End If
Next oshp
oPres.Save
oPres.Close
Set oPres = Nothing
sFileName = Dir()
Wend


End Sub

I would start with maybe 6 files to update as a test

I just tested the code out on a few files as suggested. It worked, but it stripped the formatting out of the rest of the text in the box that was edited. The text was previously AutoFit to fit the frame, and there was a hyperlink in the box several lines above the line with the text that was replaced. Can you think of a way to avoid that?

[John Wilson]

Maybe this would do that:


Sub EveryPresentationInFolder() Dim sFolder As String
Dim sFileSpec As String
Dim sFileName As String
Dim oPres As Presentation
Dim osld As Slide
Dim oshp As Shape
Dim FindThis As String
Dim ReplaceWith As String
Dim ipos As Integer
Dim otr As TextRange
' CAREFUL your files will be overwritten!
' MAKE A COPY OF THE FILES AND PUT IN A FOLDER ON THE DESKTOP CALLED Files


'change these
FindThis = "Joe Bloggs"
ReplaceWith = "Fred Carney"
sFolder = Environ("USERPROFILE") & "\Desktop\test\"


sFileSpec = "*.PPTX"


sFileName = Dir$(sFolder & sFileSpec)


While sFileName <> ""
Set oPres = Presentations.Open(sFolder & sFileName, ReadOnly:=msoFalse, WithWindow:=False)
Set osld = oPres.Slides(oPres.Slides.Count) 'last slide
For Each oshp In osld.Shapes
If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then
Set otr = oshp.TextFrame.TextRange.Find(FindThis)
If Not otr Is Nothing Then otr.Replace FindThis, ReplaceWith
End If
End If
Next oshp
oPres.Save
oPres.Close
Set oPres = Nothing
sFileName = Dir()
Wend


End Sub

[wakruger]

Maybe this would do that:



Hmm, now it doesn't seem to do anything when I run the macro. No blips or any indication of activity in PowerPoint and the files are not changed.

Edit: I have the macro loaded into a module in a PPT file called MyPowerPointMacros saved in My Documents. This is how I ran it before this last code tweak. Please let me know if I should load and run the macro differently. I am definitely a VBAX Newbie!

[John Wilson]

Just checking you did alter the FindThis and ReplaceWith settings this time??

If you have a sample of the last slide that would help (remove any sensitive info)

[wakruger]

Just checking you did alter the FindThis and ReplaceWith settings this time??

If you have a sample of the last slide that would help (remove any sensitive info)

I just verified that I changed FindThis and ReplaceWith this time around. I have uploaded a sanitized version of one of the files I'm working with. In this example, the name John Smith on the last slide needs to be changed to Jane Doe.

[John Wilson]

Definitely works here but there was a typo in the last code! The folder is called Files not test.

My new code

[CODE]Sub EveryPresentationInFolder() Dim sFolder As String
Dim sFileSpec As String
Dim sFileName As String
Dim oPres As Presentation
Dim osld As Slide
Dim oshp As Shape
Dim FindThis As String
Dim ReplaceWith As String
Dim ipos As Integer
Dim otr As TextRange
' CAREFUL your files will be overwritten!
' MAKE A COPY OF THE FILES AND PUT IN A FOLDER ON THE DESKTOP CALLED Files


'change these
FindThis = "John Smith"
ReplaceWith = "Jane Doe"
sFolder = Environ("USERPROFILE") & "\Desktop\Files\"


sFileSpec = "*.PPTX"


sFileName = Dir$(sFolder & sFileSpec)


While sFileName <> ""
Set oPres = Presentations.Open(sFolder & sFileName, ReadOnly:=msoFalse, WithWindow:=False)
Set osld = oPres.Slides(oPres.Slides.Count) 'last slide
For Each oshp In osld.Shapes
If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then
Set otr = oshp.TextFrame.TextRange.Find(FindThis)
If Not otr Is Nothing Then otr.Replace FindThis, ReplaceWith
End If
End If
Next oshp
oPres.Save
oPres.Close
Set oPres = Nothing
sFileName = Dir()
Wend


End Sub


The result
15546

[wakruger]

I must be doing something wrong in the execution, it's still not working on my end. :crying:

[John Wilson]

The site seems to be messing up the code format slightly

This should be correct:


Sub EveryPresentationInFolder()

Dim sFolder As String
Dim sFileSpec As String
Dim sFileName As String
Dim oPres As Presentation
Dim osld As Slide
Dim oshp As Shape
Dim FindThis As String
Dim ReplaceWith As String
Dim ipos As Integer
Dim otr As TextRange
' CAREFUL your files will be overwritten!
' MAKE A COPY OF THE FILES AND PUT IN A FOLDER ON THE DESKTOP CALLED Files




'change these
FindThis = "John Smith"
ReplaceWith = "Jane Doe"
sFolder = Environ("USERPROFILE") & "\Desktop\Files\"




sFileSpec = "*.PPTX"




sFileName = Dir$(sFolder & sFileSpec)




While sFileName <> ""
Set oPres = Presentations.Open(sFolder & sFileName, ReadOnly:=msoFalse, WithWindow:=False)
Set osld = oPres.Slides(oPres.Slides.Count) 'last slide
For Each oshp In osld.Shapes
If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then
Set otr = oshp.TextFrame.TextRange.Find(FindThis)
If Not otr Is Nothing Then otr.Replace FindThis, ReplaceWith
End If
End If
Next oshp
oPres.Save
oPres.Close
Set oPres = Nothing
sFileName = Dir()
Wend




End Sub

I know you are running out of time but it does work here.

See this video:

http://screencast.com/t/EH29z3De

[wakruger]

It works!! THANK YOU THANK YOU THANK YOU!!!! :bow: