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)?

https://i.imgur.com/teRdWS7.jpg

Thanks in advance
bg66
2160421605

[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?
2162321624

https://i.imgur.com/aLZc2Zh.jpg

[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:
https://i.imgur.com/eDxjTk9.jpg

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