Hi all,
I am not sure how to go to a text in powerpoint to replace with a chart -
This is what i have so far.
I'm now only having isses trying to get the charts to copy over to ppt.
let me know if i need to post under a new thread.
I like to use text in my templates that is %%string%% so that i know where to find and replace.
I have a shapes that has %%Chart1%%, %%chart2%%, etc. as the text in it. I'm trying to get it so that on sheet 2 of my excel book, where i have my charts in order, it will loop through the charts like it does with the text in sheet 1, and find the %%chart#%% in the powerpoint and paste my chart in there.
just fyi, sheet 1 has a word in column A and the replacement in column b - it loops through and edits the template accordingly.
Thanks for y'alls help.
I am not sure how to go to a text in powerpoint to replace with a chart -
This is what i have so far.
I'm now only having isses trying to get the charts to copy over to ppt.
let me know if i need to post under a new thread.
I like to use text in my templates that is %%string%% so that i know where to find and replace.
I have a shapes that has %%Chart1%%, %%chart2%%, etc. as the text in it. I'm trying to get it so that on sheet 2 of my excel book, where i have my charts in order, it will loop through the charts like it does with the text in sheet 1, and find the %%chart#%% in the powerpoint and paste my chart in there.
just fyi, sheet 1 has a word in column A and the replacement in column b - it loops through and edits the template accordingly.
Thanks for y'alls help.
Code:
Sub SanDonTimesTwo()
Dim newfn$
'open file dialogue box - limit to word/ppt
newfn = Application.GetOpenFilename(Title:="Please select a file")
If newfn = "False" Then Exit Sub
Dim PPT As PowerPoint.Application
Dim XLS As Excel.Application
Dim xlWs As Worksheet
Dim WRD As Word.Application
Dim wdDoc As Word.Document
Dim strWhatReplace As String
Dim strReplaceText As String
Dim lastrow As Long
Dim cht As Excel.ChartObject
Dim c As Integer
Dim oSection As Object
Dim stitle As String
Set xlWs = ActiveSheet
lastrow = Range("A1048576").End(xlUp).Row
'below determines the extension of the chosen file, then runs respective macro
Select Case Split(newfn, ".")(UBound(Split(newfn, ".")))
''''''''''''''''powerpoint starts here
Case "ppt", "pptx", "potx", "potm"
'do for pp
On Error Resume Next
Set PPT = New PowerPoint.Application
PPT.Presentations.Open filename:=newfn
Dim PPTApp As PowerPoint.Application
Dim oSld As PowerPoint.Slide
Dim oShp As PowerPoint.Shape
Dim oTxtRng As TextRange
Dim oTmpRng As TextRange
Dim i As Integer
For i = 2 To lastrow
' write find text
strWhatReplace = Cells(i, 1).Value
' write change text
strReplaceText = Cells(i, 2).Value
PPT.ActivePresentation.Slides(1).Select
' go during each slide
For Each oSld In PPT.ActivePresentation.Slides
' go during each shapes and textRanges
For Each oShp In oSld.Shapes
' replace in TextFrame
Set oTxtRng = oShp.TextFrame.TextRange
Set oTmpRng = oTxtRng.Replace( _
FindWhat:=strWhatReplace, _
Replacewhat:=strReplaceText, _
WholeWords:=False)
Do While Not oTmpRng Is Nothing
Set oTxtRng = oTxtRng.Characters _
(oTmpRng.Start + oTmpRng.Length, oTxtRng.Length)
Set oTmpRng = oTxtRng.Replace( _
FindWhat:=strWhatReplace, _
Replacewhat:=strReplaceText, _
WholeWords:=False)
Loop
Next oShp
Next oSld
Excel.ActiveWorkbook.Sheets(1).Select
Next i
' '''''Optional loop through charts on sheet2? (c will be the chart counter for reference)
b = MsgBox("are there charts to import?", vbYesNo)
If b = vbYes Then
XLS.ActiveWorkbook.Sheet(2).Select
c = 1
For c = 1 To ActiveSheet.ChartObjects.Count
'determine chart title
ActiveChart.Name = "%%Chart" & c & "%%"
Chartname = ActiveChart.Name
ActiveSheet.ChartObjects(icht).Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
PPT.ActivePresentation.Slides(1).Select
For Each oSld In PPT.ActivePresentation.Slides
' go during each shapes and textRanges
For Each oShp In oSld.Shapes
' replace in TextFrame
Set oTxtRng = oShp.TextFrame.TextRange
Set oTmpRng = oTxtRng.Find( _
FindWhat:=Chartname)
Shapes.PasteSpecial(ppPasteMetafilePicture).Select
'Replacewhat:=strReplaceText, _
WholeWords:=False)
Do While Not oTmpRng Is Nothing
Set oTxtRng = oTxtRng.Characters _
(oTmpRng.Start + oTmpRng.Length, oTxtRng.Length)
Set oTmpRng = oTxtRng.Find( _
FindWhat:=Chartname)
PPT.ActivePresentation.Slides.Paste.Select
', _
Replacewhat:=strReplaceText, _
WholeWords:=False)
Loop
Next oShp
Next oSld
icht = icht + 1
Excel.ActiveWorkbook.Sheets(2).Select
Next c
PPT.Visible = True
Else
PPT.Visible = True
Exit Sub
End If
'''''''''''''''''''''''''''Word starts here
Case "doc", "docx", "dotm"
'do for word
On Error Resume Next
Set WRD = New Word.Application
Set wdDoc = WRD.Documents.Open(filename:=newfn)
Dim J As Integer
For J = 2 To lastrow
' write find text
strWhatReplace = xlWs.Cells(J, 1).Value
' write change text
strReplaceText = xlWs.Cells(J, 2).Value
With wdDoc.Range.Find
' replace in word
.ClearFormatting
.Replacement.ClearFormatting
.text = strWhatReplace
.Replacement.text = strReplaceText
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
For Each oSection In wdDoc.Sections() 'from [url=http://www.vbaexpress.com/forum/showthread.php?t=6130]Solved: Find and Replace in Footer - VBA Express Forum[/url]
For Var = 1 To 3
oSection.Footers(Var).Range.Find.Execute _
FindText:=xlWs.Cells(J, 1).Value, _
ReplaceWith:=xlWs.Cells(J, 2).Value, _
Replace:=2
oSection.Headers(Var).Range.Find.Execute _
FindText:=xlWs.Cells(J, 1).Value, _
ReplaceWith:=xlWs.Cells(J, 2).Value, _
Replace:=2
Next Var
Next
Excel.ActiveWorkbook.Sheets(1).Select
Next J
WRD.Visible = True
Case Else
a = MsgBox("Please Select Only a Word or Powerpoint File", vbOKOnly)
Exit Sub
End Select
End Sub
