# Excel VBA to Export PowerPoint Slide Number and Slide Title to an Excel Spreadsheet (Creating a PPT Directory)



## wilsonlow (Mar 21, 2017)

Hello, I have regular conference calls that are presented in PowerPoint slides. I'd like to create an Excel spreadsheet to act as a Directory. The main purpose is to have a centralized location to allow users to easily find a particular information buried in one of the many PowerPoint files.

Is there a VBA code that can I can select a PowerPoint file and export each slide title and slide number on an excel spreadsheet?

For example:

Column A - Hyperlink to open up the PowerPoint file (if possible a direct link to the specific slide. e.g.: Slide 5 when we open up the file)
Column B - PowerPoint File Name
Column C - PowerPoint Slide Title
Column D - PowerPoint Slide Number

Very much appreciated!


----------



## wilsonlow (Mar 21, 2017)

Bring this threat up. Any advice appreciated. Thanks.


----------



## Domenic (Mar 21, 2017)

wilsonlow said:


> Bring this threat up. Any advice appreciated. Thanks.




It's the first time anyone has threatened to...  Oh I see... you mean thread... 

Anyway, the following code will prompt the user to select one or more PowerPoint files, and then will list the information in a newly created Excel workbook.  The information for each PowerPoint file will be listed in a separate worksheet.  Note that the code should be copied into a regular module (VBE > Insert > Module) in Excel.


```
[COLOR=darkblue]Option[/COLOR] [COLOR=darkblue]Explicit[/COLOR]

[COLOR=darkblue]Sub[/COLOR] CreatePPTDirectory()

    [COLOR=green]'Declare PowerPoint variables[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] ppApp [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] ppPres [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] ppSlide [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
    
    [COLOR=green]'Declare Excel variables[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] vFileNames [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Variant[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] wbDest [COLOR=darkblue]As[/COLOR] Workbook
    [COLOR=darkblue]Dim[/COLOR] wsDest [COLOR=darkblue]As[/COLOR] Worksheet
    [COLOR=darkblue]Dim[/COLOR] NextRow [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] i [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] bNew [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Boolean[/COLOR]
    
    [COLOR=green]'Prompt user to select one or more PowerPoint files[/COLOR]
    vFileNames = Application.GetOpenFilename( _
        FileFilter:="PowerPoint Files (*.pptx;*.pptm), *.pptx;*.pptm", _
        Title:="Select one or more PowerPoint Files . . .", _
        ButtonText:="Select", _
        Multi[COLOR=darkblue]Select[/COLOR]:=True)
        
    [COLOR=green]'If user cancels, exit the sub[/COLOR]
    [COLOR=darkblue]If[/COLOR] [COLOR=darkblue]Not[/COLOR] IsArray(vFileNames) [COLOR=darkblue]Then[/COLOR] [COLOR=darkblue]Exit[/COLOR] [COLOR=darkblue]Sub[/COLOR]
    
    [COLOR=green]'Turn off screen updating[/COLOR]
    Application.ScreenUpdating = [COLOR=darkblue]False[/COLOR]
    
    [COLOR=green]'Create a new workbook in which to list the information[/COLOR]
    [COLOR=darkblue]Set[/COLOR] wbDest = Application.Workbooks.Add(Template:=xlWBATWorksheet)
    
    [COLOR=green]'Start PowerPoint, if not already open[/COLOR]
    [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]Resume[/COLOR] [COLOR=darkblue]Next[/COLOR]
    [COLOR=darkblue]Set[/COLOR] ppApp = GetObject(, "PowerPoint.Application")
    [COLOR=darkblue]If[/COLOR] ppApp [COLOR=darkblue]Is[/COLOR] [COLOR=darkblue]Nothing[/COLOR] [COLOR=darkblue]Then[/COLOR]
        [COLOR=darkblue]Set[/COLOR] ppApp = CreateObject("PowerPoint.Application")
        bNew = [COLOR=darkblue]True[/COLOR]
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]GoTo[/COLOR] 0
    
    [COLOR=green]'Open each PowerPoint file and list its corresponding information in a newly created worksheet[/COLOR]
    [COLOR=darkblue]For[/COLOR] i = 1 [COLOR=darkblue]To[/COLOR] [COLOR=darkblue]UBound[/COLOR](vFileNames)
        [COLOR=darkblue]Set[/COLOR] ppPres = ppApp.Presentations.Open(vFileNames(i))
        [COLOR=darkblue]Set[/COLOR] wsDest = wbDest.Worksheets.Add(Before:=wbDest.Worksheets(i))
        [COLOR=darkblue]With[/COLOR] wsDest
            .Range("A1:C1").Value = Array("FileName", "Slide Title", "Slide Number")
            .Hyperlinks.Add Anchor:=.Range("A2"), Address:=vFileNames(i), TextToDisplay:=ppPres.Name
            NextRow = 2
            [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] ppSlide [COLOR=darkblue]In[/COLOR] ppPres.Slides
                .Cells(NextRow, "B").Value = GetSlideTitle(ppSlide)
                .Cells(NextRow, "C").Value = ppSlide.SlideNumber
                NextRow = [COLOR=darkblue]Next[/COLOR]Row + 1
            [COLOR=darkblue]Next[/COLOR] ppSlide
            .Name = ppPres.Name
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
        ppPres.Close
    Next i
    
    [COLOR=green]'Delete the extra sheet, and make the first sheet the active sheet[/COLOR]
    [COLOR=darkblue]With[/COLOR] wbDest
        Application.DisplayAlerts = [COLOR=darkblue]False[/COLOR]
        .Worksheets(.Worksheets.Count).Delete
        Application.DisplayAlerts = [COLOR=darkblue]True[/COLOR]
        .Worksheets(1).Activate
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    
    [COLOR=green]'Quit PowerPoint, if it was started[/COLOR]
    [COLOR=darkblue]If[/COLOR] bNew [COLOR=darkblue]Then[/COLOR]
        ppApp.Quit
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    
    [COLOR=green]'Turn on screen updating[/COLOR]
    Application.ScreenUpdating = [COLOR=darkblue]True[/COLOR]
    
    [COLOR=green]'Clear the variables from memory[/COLOR]
    [COLOR=darkblue]Set[/COLOR] ppApp = [COLOR=darkblue]Nothing[/COLOR]
    [COLOR=darkblue]Set[/COLOR] ppPres = [COLOR=darkblue]Nothing[/COLOR]
    [COLOR=darkblue]Set[/COLOR] ppSlide = [COLOR=darkblue]Nothing[/COLOR]
    [COLOR=darkblue]Set[/COLOR] wbDest = [COLOR=darkblue]Nothing[/COLOR]
    [COLOR=darkblue]Set[/COLOR] wsDest = [COLOR=darkblue]Nothing[/COLOR]
    
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]
```


```
[COLOR=darkblue]Private[/COLOR] [COLOR=darkblue]Function[/COLOR] GetSlideTitle([COLOR=darkblue]ByVal[/COLOR] ppSlide [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]) [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] ppPlaceHolder [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
    [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] ppPlaceHolder [COLOR=darkblue]In[/COLOR] ppSlide.Shapes.Placeholders
        [COLOR=darkblue]Select[/COLOR] [COLOR=darkblue]Case[/COLOR] ppPlaceHolder.PlaceholderFormat.Type
            [COLOR=darkblue]Case[/COLOR] 1, 3, 5 [COLOR=green]'ppPlaceholderTitle, ppPlaceholderCenterTitle, and ppPlaceholderVerticalTitle[/COLOR]
                GetSlideTitle = ppPlaceHolder.TextFrame2.TextRange.Text
                [COLOR=darkblue]Exit[/COLOR] [COLOR=darkblue]Function[/COLOR]
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Select[/COLOR]
    [COLOR=darkblue]Next[/COLOR] ppPlaceHolder
    GetSlideTitle = ""
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Function[/COLOR]
```

Hope this helps!


----------



## wilsonlow (Mar 22, 2017)

Thanks a BILLION! Really appreciate your help Domenic! You got me! Pardon my broken English. :D 

Thanks again! This is exactly what I'm looking for. There are some minor errors, but I managed to find a counter solution for it. Before I post the final code (to share with others), I'm trying to solve for 1 more thing. 

For Column A, I decided to put a hyperlink to open the PPT file (we can ignore the hyperlink that goes directly to a specific slide). If a ppt slide has 14 slides, I would like to have 14 hyperlinks at column A. The hyperlink should also have the text display as "Open File". I tried to solve it myself but I keep getting an error on it. Would appreciate if you or someone can help. 

Here's the partial code, and the specific line I have error is:

.Cells(NextRow, "A").Hyperlinks.Add Anchor:=.Range("A2").Offset(NextRow, "A"), Address:=vFileNames(i), TextToDisplay:="Open File"


```
For i = 1 To UBound(vFileNames)        'Error exist - I added the following line
        ppApp.Visible = True
        Set ppPres = ppApp.Presentations.Open(vFileNames(i))
        Set wsDest = wbDest.Worksheets.Add(Before:=wbDest.Worksheets(i))
        With wsDest
            'Changed File Name to Hyperlink
            .Range("A1:C1").Value = Array("Hyperlink", "Slide Title", "Slide Number")
            'Deleted the Hyperlink line
            
            NextRow = 2
            For Each ppSlide In ppPres.Slides
                .Cells(NextRow, "B").Value = GetSlideTitle(ppSlide)
                .Cells(NextRow, "C").Value = ppSlide.SlideNumber
                'Replace the Hyperlink line with this
                .Cells(NextRow, "A").Hyperlinks.Add Anchor:=.Range("A2").Offset(NextRow, "A"), Address:=vFileNames(i), TextToDisplay:="Open File"
                NextRow = NextRow + 1
            Next ppSlide
        'Error exist - I deleted name line
        End With
        ppPres.Close
    Next i
```

Appreciate your kind heart to help! Thanks again. 

If anyone can help out, that would be very much appreciated as well!


----------



## wilsonlow (Mar 22, 2017)

Actually, I managed to solved it by myself after few hours of trial and error! 

Regardless, thanks for your help Domenic!

For anyone that need the code, here you go:


```
Option ExplicitSub CreatePPTDirectory()


    'Declare PowerPoint variables
    Dim ppApp As Object
    Dim ppPres As Object
    Dim ppSlide As Object
    
    'Declare Excel variables
    Dim vFileNames As Variant
    Dim wbDest As Workbook
    Dim wsDest As Worksheet
    Dim NextRow As Long
    Dim i As Long
    Dim bNew As Boolean
    
    'Prompt user to select one or more PowerPoint files
    vFileNames = Application.GetOpenFilename( _
        FileFilter:="PowerPoint Files (*.pptx;*.pptm), *.pptx;*.pptm", _
        Title:="Select one or more PowerPoint Files . . .", _
        ButtonText:="Select", _
        MultiSelect:=True)
        
    'If user cancels, exit the sub
    If Not IsArray(vFileNames) Then Exit Sub
    
    'Turn off screen updating
    Application.ScreenUpdating = False
    
    'Create a new workbook in which to list the information
    Set wbDest = Application.Workbooks.Add(Template:=xlWBATWorksheet)
    
    'Start PowerPoint, if not already open
    On Error Resume Next
    Set ppApp = GetObject(, "PowerPoint.Application")
    If ppApp Is Nothing Then
        Set ppApp = CreateObject("PowerPoint.Application")
        bNew = True
    End If
    On Error GoTo 0
    
    'Open each PowerPoint file and list its corresponding information in a newly created worksheet
    For i = 1 To UBound(vFileNames)
        'Error exist - Added the following line
        ppApp.Visible = True
        Set ppPres = ppApp.Presentations.Open(vFileNames(i))
        Set wsDest = wbDest.Worksheets.Add(Before:=wbDest.Worksheets(i))
        With wsDest
            'Changed File Name to Hyperlink
            .Range("A1:C1").Value = Array("Hyperlink", "Slide Title", "Slide Number")
            'Deleted the Hyperlink line
            
            NextRow = 2
            For Each ppSlide In ppPres.Slides
                .Cells(NextRow, "B").Value = GetSlideTitle(ppSlide)
                .Cells(NextRow, "C").Value = ppSlide.SlideNumber
                'Replace the Hyperlink line with this
                .Cells(NextRow, "A").Hyperlinks.Add Anchor:=.Cells(NextRow, "A"), Address:=vFileNames(i), TextToDisplay:="Open File"
                NextRow = NextRow + 1
            Next ppSlide
        'Error exist - Deleted name line
        End With
        ppPres.Close
    Next i
    
    'Auto fit
    Columns("A:C").Select
    Columns("A:C").EntireColumn.AutoFit
    
    'Delete the extra sheet, and make the first sheet the active sheet
    With wbDest
        Application.DisplayAlerts = False
        .Worksheets(.Worksheets.Count).Delete
        Application.DisplayAlerts = True
        .Worksheets(1).Activate
    End With
    
    'Quit PowerPoint, if it was started
    If bNew Then
        ppApp.Quit
    End If
    
    'Turn on screen updating
    Application.ScreenUpdating = True
    
    'Clear the variables from memory
    Set ppApp = Nothing
    Set ppPres = Nothing
    Set ppSlide = Nothing
    Set wbDest = Nothing
    Set wsDest = Nothing
    
End Sub


Private Function GetSlideTitle(ByVal ppSlide As Object) As String
    Dim ppPlaceHolder As Object
    For Each ppPlaceHolder In ppSlide.Shapes.Placeholders
        Select Case ppPlaceHolder.PlaceholderFormat.Type
            Case 1, 3, 5 'ppPlaceholderTitle, ppPlaceholderCenterTitle, and ppPlaceholderVerticalTitle
                GetSlideTitle = ppPlaceHolder.TextFrame2.TextRange.Text
                Exit Function
        End Select
    Next ppPlaceHolder
    'If there is no title slide it will show as "No Title"
    GetSlideTitle = "No Title"
End Function
```


----------



## Domenic (Mar 22, 2017)

> ppApp.Visible = True



I didn't think it would be necessary to make it visible, especially since I didn't get an error when I tested it.  But it looks like it's best to do so whenever one is automating PowerPoint.  Lesson learned.  



> .Name = ppPres.Name



The error probably occurred because the name is an invalid name for the sheet.  The name either exceeds 31 characters, or it contains illegal characters.  The code can be amended to deal with such scenarios.  For example, an illegal character can be replaced with an underscore.  And, if the filename is too long, it can be shortened to 31 characters or less.  Let me know if you would like me to make this change.

Based on your latest postings, here's a revised version...


```
[COLOR=darkblue]Sub[/COLOR] CreatePPTDirectory()

    [COLOR=green]'Declare PowerPoint variables[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] ppApp [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] ppPres [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] ppSlide [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
    
    [COLOR=green]'Declare Excel variables[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] vFileNames [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Variant[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] wbDest [COLOR=darkblue]As[/COLOR] Workbook
    [COLOR=darkblue]Dim[/COLOR] wsDest [COLOR=darkblue]As[/COLOR] Worksheet
    [COLOR=darkblue]Dim[/COLOR] NextRow [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] i [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] bNew [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Boolean[/COLOR]
    
    [COLOR=green]'Prompt user to select one or more PowerPoint files[/COLOR]
    vFileNames = Application.GetOpenFilename( _
        FileFilter:="PowerPoint Files (*.pptx;*.pptm), *.pptx;*.pptm", _
        Title:="Select one or more PowerPoint Files . . .", _
        ButtonText:="Select", _
        MultiSelect:=True)
        
    [COLOR=green]'If user cancels, exit the sub[/COLOR]
    [COLOR=darkblue]If[/COLOR] [COLOR=darkblue]Not[/COLOR] IsArray(vFileNames) [COLOR=darkblue]Then[/COLOR] [COLOR=darkblue]Exit[/COLOR] [COLOR=darkblue]Sub[/COLOR]
    
    [COLOR=green]'Turn off screen updating[/COLOR]
    Application.ScreenUpdating = [COLOR=darkblue]False[/COLOR]
    
    [COLOR=green]'Create a new workbook in which to list the information[/COLOR]
    [COLOR=darkblue]Set[/COLOR] wbDest = Application.Workbooks.Add(Template:=xlWBATWorksheet)
    
    [COLOR=green]'Start PowerPoint, if not already open[/COLOR]
    [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]Resume[/COLOR] [COLOR=darkblue]Next[/COLOR]
    [COLOR=darkblue]Set[/COLOR] ppApp = GetObject(, "PowerPoint.Application")
    [COLOR=darkblue]If[/COLOR] ppApp [COLOR=darkblue]Is[/COLOR] [COLOR=darkblue]Nothing[/COLOR] [COLOR=darkblue]Then[/COLOR]
        [COLOR=darkblue]Set[/COLOR] ppApp = CreateObject("PowerPoint.Application")
        ppApp.Visible = [COLOR=darkblue]True[/COLOR]
        bNew = [COLOR=darkblue]True[/COLOR]
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]GoTo[/COLOR] 0
    
    [COLOR=green]'Open each PowerPoint file and list its corresponding information in a newly created worksheet[/COLOR]
    [COLOR=darkblue]For[/COLOR] i = 1 [COLOR=darkblue]To[/COLOR] [COLOR=darkblue]UBound[/COLOR](vFileNames)
        [COLOR=darkblue]Set[/COLOR] ppPres = ppApp.Presentations.Open(vFileNames(i))
        [COLOR=darkblue]Set[/COLOR] wsDest = wbDest.Worksheets.Add(Before:=wbDest.Worksheets(i))
        [COLOR=darkblue]With[/COLOR] wsDest
            .Range("A1:C1").Value = Array("Hyperlink", "Slide Title", "Slide Number")
            NextRow = 2
            [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] ppSlide [COLOR=darkblue]In[/COLOR] ppPres.Slides
                .Hyperlinks.Add Anchor:=.Cells(NextRow, "A"), Address:=vFileNames(i), TextToDisplay:="Open File"
                .Cells(NextRow, "B").Value = GetSlideTitle(ppSlide)
                .Cells(NextRow, "C").Value = ppSlide.SlideNumber
                NextRow = [COLOR=darkblue]Next[/COLOR]Row + 1
            Next ppSlide
            .Columns("A:C").AutoFit
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
        ppPres.Close
    Next i
    
    [COLOR=green]'Delete the extra sheet, and make the first sheet the active sheet[/COLOR]
    [COLOR=darkblue]With[/COLOR] wbDest
        Application.DisplayAlerts = [COLOR=darkblue]False[/COLOR]
        .Worksheets(.Worksheets.Count).Delete
        Application.DisplayAlerts = [COLOR=darkblue]True[/COLOR]
        .Worksheets(1).Activate
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    
    [COLOR=green]'Quit PowerPoint, if it was started[/COLOR]
    [COLOR=darkblue]If[/COLOR] bNew [COLOR=darkblue]Then[/COLOR]
        ppApp.Quit
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    
    [COLOR=green]'Turn on screen updating[/COLOR]
    Application.ScreenUpdating = [COLOR=darkblue]True[/COLOR]
    
    [COLOR=green]'Clear the variables from memory[/COLOR]
    [COLOR=darkblue]Set[/COLOR] ppApp = [COLOR=darkblue]Nothing[/COLOR]
    [COLOR=darkblue]Set[/COLOR] ppPres = [COLOR=darkblue]Nothing[/COLOR]
    [COLOR=darkblue]Set[/COLOR] ppSlide = [COLOR=darkblue]Nothing[/COLOR]
    [COLOR=darkblue]Set[/COLOR] wbDest = [COLOR=darkblue]Nothing[/COLOR]
    [COLOR=darkblue]Set[/COLOR] wsDest = [COLOR=darkblue]Nothing[/COLOR]
    
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]
```

Hope this helps!


----------



## wilsonlow (Mar 23, 2017)

Hi Domenic,

Seems like we are in a different time zone :D 

I'm not sure why the visible thing is bugging me. It produces an error and I couldn't proceed further. So I've to include that. 

For the .Name = ppPres.Name, yes, that's the exact issue that you pointed. I decided to just delete it, limiting to 32 characters will make the sheet looks weird. For the purpose of my project, I can do one PPT at a time, instead of multiple. 

Thanks again for your help and sharing! You are awesome! :D


----------

