Insert bulk hyperlink from Excel list to PowerPoint

huss3in999

New Member
Joined
Jun 27, 2020
Messages
1
Office Version
  1. 2019
  2. 2016
  3. 2013
  4. 2011
  5. 2010
Platform
  1. Windows
  2. 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

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

Untitled.png
 

Attachments

  • vba.png
    vba.png
    45.8 KB · Views: 2

Some videos you may like

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes

Watch MrExcel Video

Forum statistics

Threads
1,114,551
Messages
5,548,694
Members
410,865
Latest member
siglertl
Top