Excel VBA Help

[jah1385]

Sub GenerateCertificates()
Dim pptApp As Object
Dim pptPres As Object
Dim pptSlide As Object
Dim xlSheet As Worksheet
Dim row As Integer
Dim name As String
Dim gradDate As String
Dim savePath As String
Dim certificateTemplate As String

' Path to your PowerPoint template
certificate_Template = "C:\Users\jay\Desktop\cert\certificate_template.pptx"

' Folder to save generated certificates
savePath = "C:\Users\jay\Desktop\cert\"

' Set Excel sheet
Set xlSheet = ThisWorkbook.Sheets("Sheet2") ' Adjust sheet name if necessary

' Open PowerPoint
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = True

' Loop through rows in Excel
row = 2 ' Assuming data starts in row 2
Do While xlSheet.Cells(row, 1).Value <> ""
' Get data from Excel
name = xlSheet.Cells(row, 1).Value
gradDate = xlSheet.Cells(row, 3).Value

' Open PowerPoint template
Set pptPres = pptApp.Presentations.Open(certificate_Template)
Set pptSlide = pptPres.Slides(1) ' Adjust if template has multiple slides

' Replace placeholders in PowerPoint
Dim shp As Object
For Each shp In pptSlide.Shapes
If shp.HasTextFrame Then
If InStr(1, shp.TextFrame.TextRange.Text, "Name") > 0 Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Name", name)
End If
If InStr(1, shp.TextFrame.TextRange.Text, "Date") > 0 Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "Date", gradDate)
End If
End If
Next shp

' Save as a new PowerPoint file
pptPres.SaveAs savePath & name & "_certificate.pptx"
pptPres.Close
row = row + 1
Loop

' Clean up
pptApp.Quit
Set pptApp = Nothing
MsgBox "Certificates generated successfully!"
End Sub


i have managed to work something out but the data isn't being replicated in the actual presentation instead it saves the certificate of all the student names i.e John.ppt

i also get an error code Run-time error '-2147467259 (80004005)

Presentation Open
Presentation.Close : Failed

I am trying to link the names into the name part of the powerpoint and the date into the date textbox. i then would like the ppt to be saved in PDF

anyone can support me greatly appreciated

 

[Domenic]

With your dates in Column B, it should be . . .

gradDate = xlSheet.Cells(row, 2).Value

Cheers!

 

[Alex Blakenburg]

answer to your Qs... how do i add a breakpoint?

If you are going to be debugging code it will save you time if you learn a few debugging techniques. Here is a video by WiseOwl on the breakpoint
it's 3.5 mins long.

 

[jah1385]

If you are going to be debugging code it will save you time if you learn a few debugging techniques. Here is a video by WiseOwl on the breakpoint
it's 3.5 mins long.

Thanks Alex ill definitely learn debugging

 

[jah1385]

With your dates in Column B, it should be . . .

gradDate = xlSheet.Cells(row, 2).Value

Cheers!

Sub GenerateCertificates()

    Dim pptApp As Object
    Dim pptPres As Object
    Dim pptSlide As Object
    Dim pr As Object
    Dim shp As Object
    Dim arrShapes(1 To 2) As Object
    Dim xlSheet As Worksheet
    Dim row As Integer
    Dim name As String
    Dim gradDate As String
    Dim savePath As String
    Dim certificateTemplate As String
    
    ' Path to your PowerPoint template
    certificateTemplate = "Documents/Documents/certificate%20generation/CERTIFICATE_TEMPLATE.pptx?web=1"
    
    ' Folder to save generated certificates
    savePath = "certficategeneration"
    
    ' Set Excel sheet
    Set xlSheet = ThisWorkbook.Sheets("Sheet2") ' Adjust sheet name if necessary
    
    ' Open PowerPoint
    Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = True
    
    ' Open PowerPoint template
    Set pptPres = pptApp.Presentations.Open(certificateTemplate)
    
    Set pptSlide = pptPres.Slides(1) ' Adjust if template has multiple slides
    
    ' clear the print range and set it to the specified slide
    pptPres.PrintOptions.Ranges.ClearAll
    Set pr = pptPres.PrintOptions.Ranges.Add(Start:=pptSlide.slideNumber, End:=pptSlide.slideNumber)
    
    ' Find shape index for shape containing the name
    For Each shp In pptSlide.Shapes
        If shp.hastextframe Then
            If InStr(1, shp.TextFrame.TextRange.Text, "Name", vbTextCompare) > 0 Then
                Set arrShapes(1) = shp
                Exit For
            End If
        End If
    Next shp
    
    ' Find shape index for shape containing the date
    For Each shp In pptSlide.Shapes
        If shp.hastextframe Then
            If InStr(1, shp.TextFrame.TextRange.Text, "Date", vbTextCompare) > 0 Then
                Set arrShapes(2) = shp
                Exit For
            End If
        End If
    Next shp
        
    ' Loop through rows in Excel
    row = 2 ' Assuming data starts in row 2
    Do While xlSheet.Cells(row, 1).Value <> ""
    
        ' Get data from Excel
        name = xlSheet.Cells(row, 1).Value
        Date = xlSheet.Cells(row, 2).Value
        
        ' Replace placeholders in PowerPoint
        arrShapes(1).TextFrame.TextRange.Text = name
        arrShapes(2).TextFrame.TextRange.Text = Date
        
        ' Export slide as PDF
        pptPres.ExportAsFixedFormat Path:=savePath & name & "_certificate.pdf", _
                            FixedFormatType:=2, _
                            RangeType:=4, _
                            PrintRange:=pr, _
                            Intent:=2, _
                            FrameSlides:=msoFalse
        
        DoEvents
        
        row = row + 1
        
    Loop
    
    pptPres.Close
    
    DoEvents
    
    pptApp.Quit
    
    DoEvents
    
    ' Clean up
    Set shp = Nothing
    Set pptSlide = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
    
    AppActivate ThisWorkbook.Windows(1).Caption 'to ensure that the user sees the MsgBox that appears in Excel
    
    MsgBox "Certificates generated successfully!"
    
End Sub

please ignore the pathway thats not the issue.

RUN TIME ERROR '70'
Permission Denied

 

[Domenic]

If the path is a valid one, maybe you don't have permissions set to access that location?

Are you able to access the location manually, without code?

 

[jah1385]

If the path is a valid one, maybe you don't have permissions set to access that location?

Are you able to access the location manually, without code?

Thanks Domenic that worked like a charm as you said before haha... im still not getting the dates aligned correctly. i have complied random dates for students but it only takes the first date on that excel sheet and runs the same date for all.

 

[jah1385]

If the path is a valid one, maybe you don't have permissions set to access that location?

Are you able to access the location manually, without code?

i had a play around the codes to see if i can do anything it defaults to todays date and doesn't take the information from the excel sheet like it does for the name column. It generates names across the rows of names but dates dont change like they should according to the dates assigned to each name.

 

[Alex Blakenburg]

I am not at a computer at the moment but change both occurrences of date to gradDate and add the required date format.

' Get data from Excel
name = xlSheet.Cells(row, 1).Value
gradDate = Format(xlSheet.Cells(row, 3).Value, "mm/dd/yyyy")

' Replace placeholders in PowerPoint
arrShapes(1).TextFrame.TextRange.Text = name
arrShapes(2).TextFrame.TextRange.Text = gradDate