1 Attachment(s)
Problem with VBA code in Excel
Hi people,
I have this one VBA code created by someone and my job is to alter the code. My code is this:
Code:
Option Explicit
Sub MakePowerpoint()
Dim MyPath As String
Dim FileName As String
Dim objPPT As Object
Dim ppt As Object
Dim sld As Object
Dim shp As Object
Dim PPName As String
Dim shpIndex As Long
Dim CurSlide As Long
Dim sh As Excel.Worksheet
Dim ObjName As String
Dim ObjType As String
Dim PPSldNum As Long
Dim PPObjName As String
Dim MyTop As Double
Dim MyLeft As Double
Dim MyHeight As Double
Dim MyWidth As Double
Dim cl As Range
Dim OldText As String
Dim NewText As String
' Set up the pathname and the output PowerPoint Presentation Name
MyPath = ThisWorkbook.Path
PPName = MyPath & "\" & Range("PPReport_Name")
' Copy the template file to the PowerPoint Presentation Name
FileCopy MyPath & "\" & Range("PPTemplate_Name"), PPName
' Open the PowerPoint Presentation
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
objPPT.presentations.Open PPName
Set ppt = objPPT.activepresentation
' Add objects
For Each cl In Range("Table_Objects[Excel Page]")
ObjType = cl.Offset(0, 2).Value ' Type of the thing to copy
If ObjType <> "Text" Then
Set sh = Sheets(cl.Value) ' Excel Sheet
ObjName = cl.Offset(0, 1).Value ' Name of the thing to copy
End If
PPSldNum = cl.Offset(0, 3).Value ' PowerPoint slide number
PPObjName = cl.Offset(0, 4).Value ' PowerPoint object
MyTop = cl.Offset(0, 5).Value ' Top
MyLeft = cl.Offset(0, 6).Value ' Left
MyHeight = cl.Offset(0, 7).Value ' Height
MyWidth = cl.Offset(0, 8).Value ' Width
OldText = cl.Offset(0, 9).Value ' Old Text
NewText = cl.Offset(0, 10) ' New Text
Set sld = ppt.slides(PPSldNum) ' Active Slide
Select Case ObjType
Case "Text"
sld.Shapes(PPObjName).TextFrame.TextRange.Text = _
Replace(sld.Shapes(PPObjName).TextFrame.TextRange.Text, OldText, NewText)
Case "Chart"
sh.Shapes(ObjName).CopyPicture
Case "Range"
sh.Range(ObjName).CopyPicture
End Select
If ObjType = "Chart" Or ObjType = "Range" Then
sld.Shapes.Paste
shpIndex = sld.Shapes.Count
With sld.Shapes(shpIndex)
.LockAspectRatio = msoFalse
.Top = 72 * MyTop
.Left = 72 * MyLeft
.Height = 72 * MyHeight
.Width = 72 * MyWidth
End With
End If
Next
End Sub
Function GetText(ObjName As String, Pos As Long) As String
Dim cl As Range
Dim Result As String
Result = "Value not found"
For Each cl In Range("Table_TextFrame[PPObjName]")
If cl.Value = ObjName Then
Result = cl.Offset(0, Pos).Value
Exit For
End If
Next
GetText = Result
End Function
The part that I wanna edit is:
Code:
Select Case ObjType
Case "Text"
sld.Shapes(PPObjName).TextFrame.TextRange.Text = _
Replace(sld.Shapes(PPObjName).TextFrame.TextRange.Text, OldText, NewText)
Case "Chart"
sh.Shapes(ObjName).CopyPicture
Case "Range"
sh.Range(ObjName).CopyPicture
Case "Cell" 'this part
sh.Range(ObjName).Copy 'for keeping source formatting case'
End Select
If ObjType = "Chart" Or ObjType = "Range" Then
sld.Shapes.Paste
shpIndex = sld.Shapes.Count
With sld.Shapes(shpIndex)
.LockAspectRatio = msoFalse
.Top = 72 * MyTop
.Left = 72 * MyLeft
.Height = 72 * MyHeight
.Width = 72 * MyWidth
End With
End If
If ObjType = "Cell" Then 'this part
sld.Shapes.PasteSpecial ppPasteDefault 'paste as its default form'
shpIndex = sld.Shapes.Count
With sld.Shapes(shpIndex)
.LockAspectRatio = msoFalse
.Top = 72 * MyTop
.Left = 72 * MyLeft
.Height = 72 * MyHeight
.Width = 72 * MyWidth
End With
End If
Next
But whenever I want to try the program I have two issues:
1. The program will highlight
Code:
sld.Shapes.PasteSpecial ppPasteDefault 'paste as its default form'
and shows an error; either syntax or object not defined
2. Whenever I want to fill in the template, my excel will show this:
Attachment 20965
The way my program works is that one sheet will contain the details of the data that wants to be copied from Excel to PowerPoint including from which sheet and what kind of data either "range", "chart" or "cell" (the new feature I wanna add to keep source formatting or keeping it as its default form).
