VBA and hyperlinks in table cells

[viuf]

Hi



I'm new to the whole powerpoint way of thinking, so my question may not be as precise as one could wish, but I hope that someone is able to help me anyway

I have created a link between excel and powerpoint where the VBA in powerpoint gets the content from excel and via some two dimensional arrays post the text in a table in powerpoint.

My problem is, that I need text in every single cell to be translated into a different hyperlink. I have tried to read about hyperlinks and VBA online, but I can't seem to get it to work with my code.


Thank you in advance
-Thomas

The place in the code where I need the hyperlink:

    Set pptPres = ActivePresentation
    With pptPres
        Set pptSlide = .Slides.Add(.Slides.Count, ppLayoutBlank)
    End With
    With pptSlide.Shapes
         Set pptShape = .AddTable(NumRows:=numberOfRows, NumColumns:=numberOfColumns, Left:=distanceFromLeft, _
                                Top:=distanceFromTop, Width:=tableWidth, Height:=tableHeight)
    End With
    With pptShape.Table
        For iRow = 1 To .Rows.Count
            For iColumn = 1 To .Columns.Count
                With .Cell(iRow, iColumn).Shape.TextFrame.TextRange
                    .Text = "Spørgsmål " & vbNewLine & questions(iColumn - 1, iRow - 1) & vbNewLine & "Svar " & vbNewLine & answers(iColumn - 1, iRow - 1)
                
                    With .Font
                       .Name = "Verdana"
                       .Size = "14"
                    End With
                End With
            Next iColumn
        Next iRow
    End With

Just in case - the entire code

Sub InsertTable()
'======= Setup for TABEL =========
    Dim pptSlide As Slide
    Dim pptShape As Shape
    Dim pptPres As Presentation
    Dim iRow As Integer
    Dim iColumn As Integer
    Dim oShapeInsideTable As Shape
    Dim numberOfColumns As Double
    Dim numberOfRows As Double
    Dim iCount_rows As Integer
    Dim iCount_columns As Integer
    
    
'======= Setup for EXCEL link =========
Dim sourceXL As Excel.Application
Dim sourceBook As Excel.Workbook
Dim sourceSheet As Excel.Worksheet
Dim dataReadArray(10) As String
Dim myPress As Presentation
Dim NewSlide As Slide
Dim Q As String
Dim A As String
Set sourceXL = Excel.Application
Set sourceBook = sourceXL.Workbooks.Open("H:\Documents\VBA\Excel_fil.xlsx")
Set sourceSheet = sourceBook.Sheets(1)
Set myPress = ActivePresentation
Set NewSlide = myPress.Slides.Add(Index:=myPress.Slides.Count + 1, Layout:=ppLayoutText)
   
'======= Data to construct the tabel =======
'======= page size = 720x510
 Dim tableHeight As Integer, tableWidth As Integer, distanceFromTop As Integer, distanceFromLeft As Integer
        
        numberOfColumns = 3
        numberOfRows = 5
        tableHeight = 350
        tableWidth = 660
        distanceFromTop = 100
        distanceFromLeft = 30
        
'====== Define Array to data from EXCEL ====='
ReDim questions(0 To numberOfColumns, 0 To numberOfRows) As String
ReDim answers(0 To numberOfColumns, 0 To numberOfRows) As String
Dim row_count As Integer
Dim row_count_char As String
iCount_rows = 0
iCount_columns = 0
row_count = 2   'start for tabel i EXCEL
 
' ===== array for questions =====
Do While iCount_columns < numberOfColumns
        Do While iCount_rows < numberOfRows
            row_count_char = "G" + LTrim(Str(row_count))
            questions(iCount_columns, iCount_rows) = sourceSheet.Range(row_count_char).Value
            iCount_rows = iCount_rows + 1
            row_count = row_count + 1
        Loop
    iCount_rows = 0
    iCount_columns = iCount_columns + 1
    
Loop
' ===== array for answers =====
iCount_rows = 0
iCount_columns = 0
row_count = 2   'start for tabel i EXCEL
        
Do While iCount_columns < numberOfColumns
        Do While iCount_rows < numberOfRows
            row_count_char = "H" + LTrim(Str(row_count))
            answers(iCount_columns, iCount_rows) = sourceSheet.Range(row_count_char).Value
            iCount_rows = iCount_rows + 1
            row_count = row_count + 1
        Loop
    iCount_rows = 0
    iCount_columns = iCount_columns + 1
    
Loop
        
        
' ===== building the table ===========
    Set pptPres = ActivePresentation
    With pptPres
        Set pptSlide = .Slides.Add(.Slides.Count, ppLayoutBlank)
    End With
    With pptSlide.Shapes
         Set pptShape = .AddTable(NumRows:=numberOfRows, NumColumns:=numberOfColumns, Left:=distanceFromLeft, _
                                Top:=distanceFromTop, Width:=tableWidth, Height:=tableHeight)
    End With
    With pptShape.Table
        For iRow = 1 To .Rows.Count
            For iColumn = 1 To .Columns.Count
                With .Cell(iRow, iColumn).Shape.TextFrame.TextRange
                    .Text = "Spørgsmål " & vbNewLine & questions(iColumn - 1, iRow - 1) & vbNewLine & "Svar " & vbNewLine & answers(iColumn - 1, iRow - 1)
                
                    With .Font
                       .Name = "Verdana"
                       .Size = "14"
                    End With
                End With
            Next iColumn
        Next iRow
    End With
    
    With pptShape.Table
        ' Insert a row at the top of the table and set it's height
        .Rows.Add BeforeRow:=1
        .Rows(1).Height = 30
        Set oShapeInsideTable = .Cell(1, 1).Shape
        With oShapeInsideTable
            With .TextFrame.TextRange
                .Text = "Kategori"
                .ParagraphFormat.Alignment = ppAlignCenter
            End With
        End With
    End With
End Sub