在 VBA 中创建指向特定 powerpoint 幻灯片的单个超链接而不覆盖

Question

So I have an excel sheet with hyperlinks to other sheets before --> hyperlinks

I have created a powerpoint generator in vba, where this hyperlinks also should be transfered to the created powerpoint. I looked here for some suggestions and that's what I've created so far:

Sub pptGenerator()

Application.ScreenUpdating = False

Dim oRng As TextRange, i As Integer, j As Integer, pptC As Integer, wsCnt As Long
Dim indexText As String, indexText2 As String, t As Table, lRow As Long, lCol As Long
Dim PowerPointApp As PowerPoint.Application, myPresentation As PowerPoint.Presentation

wsCnt = ThisWorkbook.Worksheets.Count

DestinationPPT = Application.ActiveWorkbook.Path & "\PPT_template_16_9.pptx"
Set PowerPointApp = CreateObject("PowerPoint.Application")
Set myPresentation = PowerPointApp.Presentations.Open(DestinationPPT)


For pptC = 1 To 2

    For i = 1 To wsCnt
        Sheets(i).Activate
        lRow = Cells(Rows.Count, 1).End(xlUp).Row
        lCol = Cells(1, Columns.Count).End(xlToLeft).Column

        For j = 3 To lRow 'counter begins after the subtitle

            'Link to the indices point before
            If Range("A2").Value = "Subtitle" Then
                indexText2 = ActiveSheet.Range("B" & j).Offset(0, -1).Value & vbCrLf
                'Stop

                If Range("A" & j).Value = "Hyperlink 1" Then
                    Set t = PowerPointApp.ActivePresentation.slides(i).shapes(1).Table.Cell(4, 1)                                                                                                                                       
                    With t.Cell(4, 1).shape.TextFrame.TextRange.ActionSettings(ppMouseClick).Hyperlink
                        .TextToDisplay = "01 Hyperlink"
                        .SubAddress = PowerPointApp.ActivePresentation.slides(2).SlideNumber _
                            & ". " & PowerPointApp.ActivePresentation.slides(2).Name
                    End With

                End If
            End If
        Next j

        PowerPointApp.ActivePresentation.slides(i - 1).shapes(1).TextFrame.TextRange.InsertAfter indexText2

    Next i

Next pptC

Application.ScreenUpdating = True
MsgBox "Done!"

End Sub

Now I have the problem that Excel shows me the runtime error 80004005 where the method Table for the object Shape failed. Otherwise, instead of using a table, if I'll do it like this:

Set oRng = PowerPointApp.ActivePresentation.slides(i - 1).shapes(1).TextFrame.TextRange.ActionSettings(ppMouseClick).Hyperlink
With oRng
    .SubAddress = PowerPointApp.ActivePresentation.slides(2).SlideNumber _
        & ". " & PowerPointApp.ActivePresentation.slides(2).Name
End With

The last Hyperlink will taken for whole sheet, so it will be overwritten.

How can I solve this problem?

Answer 1

I fixed the problem by using this oRng instead of using a table object

If Range("A" & j).Value = "Hyperlink 1" Then
   Set oRng = PowerPointApp.ActivePresentation.slides(i - 1).Shapes(1).TextFrame.TextRange.InsertAfter(indexText2)
   With oRng.ActionSettings(ppMouseClick).Hyperlink
            .SubAddress = PowerPointApp.ActivePresentation.slides(2).SlideNumber _
             & ". " & PowerPointApp.ActivePresentation.slides(2).Name
   End With
End If