Increase informations from Powerpoint to excel

[bg66]

Hi,
I need help for increase informations to transfer from Powerpoint to Excel.
This is the macro:

Sub SaveToExcel() 'ADDED
    Dim oXLApp As Object
    Dim oWb As Object
    Dim row As Long
    
    Set oXLApp = CreateObject("Excel.Application")
    'On a Mac change \ to : in the following line
    Set oWb = oXLApp.Workbooks.Open(ActivePresentation.Path & "\" & "Results.xlsx")
    If oWb.Worksheets(1).Range("A1") = "" Then
        oWb.Worksheets(1).Range("A1") = "Name"
        oWb.Worksheets(1).Range("B1") = "Number Correct"
        oWb.Worksheets(1).Range("C1") = "Number Incorrect"
        oWb.Worksheets(1).Range("D1") = "Percentage"
    End If
    row = 2
    While oWb.Worksheets(1).Range("A" & row) <> ""
        row = row + 1
    Wend
    oWb.Worksheets(1).Range("A" & row) = userName
    oWb.Worksheets(1).Range("B" & row) = numCorrect
    oWb.Worksheets(1).Range("C" & row) = numIncorrect
    oWb.Worksheets(1).Range("D" & row) = 100 * (numCorrect / (numCorrect + numIncorrect))
    
    oWb.Save
    oWb.Close
End Sub

What should I do if I want to transfer in excel file (results.xlsx) another two information ( today's date ed title of presentation)?



Thanks in advance
bg66
Example10-05.pptmResults.xlsx

[John Wilson]

Is the "Title" actually in a Title Placeholder?

[bg66]

Yes.
But if you think this is incorrect, please give me your advice.

Thanks
BG

[John Wilson]

It is important that the title IS in a Title placeholder

See if this works

Sub SaveToExcel()    'ADDED
    Dim oXLApp As Object
    Dim oWb As Object
    Dim row As Long
    Dim strTitle As String
    Dim strdate As String


    If ActivePresentation.Slides(1).Shapes.HasTitle Then
        If ActivePresentation.Slides(1).Shapes.Title.TextFrame.HasText Then
            strTitle = ActivePresentation.Slides(1).Shapes.Title.TextFrame.TextRange
        Else
        End If
    Else
        strTitle = "No Title found"
    End If
    strdate = Format(Date, "dd/mm/yyyy")
    Set oXLApp = CreateObject("Excel.Application")
    'On a Mac change \ to : in the following line
    Set oWb = oXLApp.Workbooks.Open(ActivePresentation.Path & "\" & "Results.xlsx")
    If oWb.Worksheets(1).Range("A1") = "" Then
        oWb.Worksheets(1).Range("A1") = "Title"
        oWb.Worksheets(1).Range("B1") = "Date"
        oWb.Worksheets(1).Range("C1") = "Name"
        oWb.Worksheets(1).Range("D1") = "Number Correct"
        oWb.Worksheets(1).Range("E1") = "Number Incorrect"
        oWb.Worksheets(1).Range("F1") = "Percentage"
    End If
    row = 2
    While oWb.Worksheets(1).Range("A" & row) <> ""
        row = row + 1
    Wend
    oWb.Worksheets(1).Range("A" & row) = strTitle
    oWb.Worksheets(1).Range("B" & row) = strdate
    oWb.Worksheets(1).Range("C" & row) = username
    oWb.Worksheets(1).Range("D" & row) = numCorrect
    oWb.Worksheets(1).Range("E" & row) = numIncorrect
    oWb.Worksheets(1).Range("F" & row) = Format(100 * (numCorrect / (numCorrect + numIncorrect)), "##.#") & "%"
    oWb.Save
    oWb.Close
End Sub

[bg66]

Thanks John for your answer.
The title is in a Title placeholder but I read "No Title found" in excel file. I do not understand why it happens?
Example10-05c.pptmResults.xlsx

[John Wilson]

Almost certainly because it isn't really in a title placeholder. Select the "Title" and run this code

Sub isTitle()
    Dim lngType As Long
    With ActiveWindow.Selection.ShapeRange(1)
        If .Type = msoPlaceholder Then
            lngType = ActiveWindow.Selection.ShapeRange(1).PlaceholderFormat.Type
            Select Case lngType
            Case Is = 1, 3
                MsgBox "This is a placeholder type: " & lngType & " Title type"
            Case Else
                MsgBox "This is a placeholder type: " & lngType & " NOT Title type"
            End Select
        Else
            MsgBox "Not a placeholder"
        End If
    End With
End Sub

[bg66]

This is the results:


How can I solve it?

[John Wilson]

The easiest way would be to go to the selection Pane and rename the shape with the Title to e.g. "Title"

Then :

Sub SaveToExcel()    'ADDED
    Dim oXLApp As Object
    Dim oWb As Object
    Dim row As Long
    Dim strTitle As String
    Dim strdate As String


With ActivePresentation.Slides(1).Shapes("Title")
strTitle = .TextFrame.TextRange
If strTitle = "" Then strTitle = "Not Found"
End With
    strdate = Format(Date, "dd/mm/yyyy")
    Set oXLApp = CreateObject("Excel.Application")
    'On a Mac change \ to : in the following line
    Set oWb = oXLApp.Workbooks.Open(ActivePresentation.Path & "\" & "Results.xlsx")
    If oWb.Worksheets(1).Range("A1") = "" Then
        oWb.Worksheets(1).Range("A1") = "Title"
        oWb.Worksheets(1).Range("B1") = "Date"
        oWb.Worksheets(1).Range("C1") = "Name"
        oWb.Worksheets(1).Range("D1") = "Number Correct"
        oWb.Worksheets(1).Range("E1") = "Number Incorrect"
        oWb.Worksheets(1).Range("F1") = "Percentage"
    End If
    row = 2
    While oWb.Worksheets(1).Range("A" & row) <> ""
        row = row + 1
    Wend
    oWb.Worksheets(1).Range("A" & row) = strTitle
    oWb.Worksheets(1).Range("B" & row) = strdate
    oWb.Worksheets(1).Range("C" & row) = username
    oWb.Worksheets(1).Range("D" & row) = numCorrect
    oWb.Worksheets(1).Range("E" & row) = numIncorrect
    oWb.Worksheets(1).Range("F" & row) = Format(100 * (numCorrect / (numCorrect + numIncorrect)), "##.#") & "%"
    oWb.Save
    oWb.Close
End Sub

[bg66]

John, thank you so much for your help! Works perfectly.

BG66