huss3in999
New Member
- Joined
- Jun 27, 2020
- Messages
- 1
- Office Version
- 2019
- 2016
- 2013
- 2011
- 2010
- Platform
- Windows
- Web
Hi I have PowerPoint has 83 slides each slide have 12 images and 12 textboxes (textbox names for each slide start from 1 to 12)
What I'm trying to do I have excel sheet which has all my data
Column A has a slide number For the PowerPoint
Column B has textbox name
Column c has a title which will be transferred to a textbox
Macro code I have will find slide number and textbox or shape name and will insert title from column c
I'm missing with one code I want to insert hyperlink for each name of textbox or on title
Column E I have my hyperlink list which I need to insert for each textbox in PowerPoint
What I'm trying to do I have excel sheet which has all my data
Column A has a slide number For the PowerPoint
Column B has textbox name
Column c has a title which will be transferred to a textbox
Macro code I have will find slide number and textbox or shape name and will insert title from column c
I'm missing with one code I want to insert hyperlink for each name of textbox or on title
Column E I have my hyperlink list which I need to insert for each textbox in PowerPoint
VBA Code:
Dim ppapp As PowerPoint.Application
Dim pppres As PowerPoint.Presentation
Sub getshapedata()
Set ppapp = GetObject(, "Powerpoint.application")
Set ppres = ppapp.ActivePresentation
On Error GoTo line1
Dim shapeslide
Dim shapename
Dim shapetext
Dim nextrow
shapeslide = ppapp.ActiveWindow.View.Slide.SlideIndex
shapename = ppapp.ActiveWindow.Selection.ShapeRange(1).Name
shapetext = ppres.Slides(shapeslide).Shapes(shapename).TextEffect.Text
friendlyname = InputBox("Insert Friendly Name for " & shapetext, "FriendlyName", "")
nextrow = Sheet2.Range("a" & Rows.Count).End(xlUp).Row + 1
Sheet2.Range("a" & nextrow) = shapeslide
Sheet2.Range("b" & nextrow) = shapename
Sheet2.Range("c" & nextrow) = shapetext
Sheet2.Range("d" & nextrow) = friendlyname
Exit Sub
line1:
MsgBox ("No item selected")
End Sub
Sub writedata()
Dim c As Object
Dim shapeslide
Dim shapename
Dim shapetext
Set ppapp = GetObject(, "Powerpoint.application")
Set ppres = ppapp.ActivePresentation
For Each c In Sheet2.Range("a2:a" & Sheet2.Range("a" & Rows.Count).End(xlUp).Row)
shapeslide = Sheet2.Range("a" & c.Row)
shapename = Sheet2.Range("b" & c.Row)
shapetext = Sheet2.Range("c" & c.Row).Text
friendlyname = Sheet2.Range("d" & c.Row)
ppres.Slides(shapeslide).Shapes(shapename).TextEffect.Text = shapetext
Next c
End Sub