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

 

[jah1385]

I think this should be column 2 not 3 eg:

gradDate = Format(xlSheet.Cells(row, 2).Value, "mm/dd/yyyy")

Alex i did notice that before apologises i should've said i've changed that to row 2 but it still reflects todays date for ALL STUDENTS..

 

[Alex Blakenburg]

Please repost the entire code and an image showing what column the dates are in and what dates you have there/

 

[jah1385]

here is the code i'm using

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 = "C:\Users\Desktop\certificate generation\CERTIFICATE_TEMPLATE.pptx"



' Folder to save generated certificates

savePath = "C:\Users\Desktop\certificate generation\"



' 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",[B] vbTextCompare[/B]) > 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", [B]vbTextCompare[/B]) > 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

gradDate = Format(xlSheet.Cells(row, 2).Value, "mm/dd/yyyy")



' 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

Excel sheet is called Sheet2

 

[jah1385]

I have updated the excel field to Graddate as well which doesn't work either