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