I have problem with the macro VBA macro. It did work, but now is does not work anymore. Does anybody have a clue what might go wrong?
Sub SaveName()
Dim i As Integer
Dim pptcount As Integer
Dim pptapp As PowerPoint.Presentation
Dim pres As Presentations
Dim var1 As String
Set pptapp = CreateObject("Powerpoint.Application")
pptapp.Visible = True
Set pres = Application.Presentations(i)
var1 = InputBox("geef hier je maand aan")
pptcount = Application.Presentations.Count
For i = 1 To pptcount
Application.ActivePresentation.SaveAs "X:\SSC_HR\SENS\Bedrijfsbureau\Rapportages\SENS referenten rapportage\Template_Uploaden\" & "var1" & ".ppt"
Next
End Sub
Try this instead, see comments:
Sub SaveName()
' VBA will convert this stuff for you
' but internally they're longs
' May as well dim them correctly to start with
Dim i As Long
Dim pptcount As Long
' Dim this as Application, not as presentation:
Dim pptapp As PowerPoint.Application
Dim pres As Presentation
Dim var1 As String
Set pptapp = CreateObject("Powerpoint.Application")
pptapp.Visible = True
Set pres = Application.Presentations(i)
var1 = InputBox("geef hier je maand aan")
pptcount = Application.Presentations.Count
For i = 1 To pptcount
Application.ActivePresentation.SaveAs "X:\SSC_HR\SENS\Bedrijfsbureau\Rapportages\SENS referenten rapportage\Template_Uploaden\" & "var1" & ".ppt"
Next
End Sub
I haven't run it, but at least it compiles now. ;-)
Steve said he didn't RUN it there are several errors and it's not at all clear what it should do.
Not an error but probably not needed
Set pptapp = CreateObject("Powerpoint.Application")
pptapp.Visible = True
ERROR
Set pres = Application.Presentations(i) 'i is zero so it will fail
ERRORS
This is saving the same presentation several times and var1 should NOT be in ""
For i = 1 To pptcount
Application.ActivePresentation.SaveAs "X:\SSC_HR\SENS\Bedrijfsbureau\Rapportages\SENS referenten rapportage\Template_Uploaden\" & "var1" & ".ppt"
Next
Related
I have a question regarding the following code. The code now works, but did not until I set the Variables to nothing (see the part with the *** in the code). I got all kinds of error-messages (e.g. "462 The remote server machine does not exist or is unavailable")
My question is: Why do I have to Set those Variables to nothing? I guess it has something to do with the fact that I use a loop right?
Thanks in advance!
Sub Saveas_PDF()
Dim PP As PowerPoint.Presentation
Dim prs As PowerPoint.Presentation
Dim Sl As PowerPoint.Slide
Dim sh As Variant
Dim company As String
Set Dropdown.ws_company = Tabelle2
company = Dropdown.ws_company.Range("C2").Value
Dim strPOTX As String
Dim strPfad As String
Dim pptApp As Object
Call filepicker
Dim Cell As Range
For Each Cell In Dropdown.ws_company.Range(Dropdown.ws_company.Cells(5, 3),
Dropdown.ws_company.Cells(Rows.Count,
3).End(xlUp)).SpecialCells(xlCellTypeVisible)
Dropdown.ws_company.Range("C2") = Cell
Set pptApp = New PowerPoint.Application
Dim pptVorlage As String
pptVorlage = myfilename
Set PP = pptApp.Presentations.Open(pptVorlage)
PP.UpdateLinks 'Datei --> Informationen --> Verknüpfungen --> Automatisch
aktualisieren Haken setzen
Dim newpath As String
newpath = Replace(myfilename, "AXO", "" & Cell & " AXO")
Dim newpathpdf As String
newpathpdf = Replace(newpath, "pptx", "pdf")
PP.ExportAsFixedFormat "" & newpathpdf & "", ppFixedFormatTypePDF,
ppFixedFormatIntentPrint
pptApp.Visible = True
Debug.Print (PP.Name)
AppActivate (PP.Name)
PP.Close
***Set pptApp = Nothing
Set PP = Nothing***
Next
Set pptApp = New PowerPoint.Application
If IsAppRunning("PowerPoint.Application") Then
If pptApp.Windows.Count = 0 Then
pptApp.Quit
End If
End If
End Sub
Maybe because you are calling the constructor "New" inside de loop in the line: Set pptApp = New PowerPoint.Application
Move the line "Set pptApp = New PowerPoint.Application" before de foreach and try it.
I want to Export large data stock from Access to Excel. I'm doing that with a form.
My code with "DoCmd.TransferSpreadsheet acExport..." works normally, but the program breaks off because of the large data stock.
Perhaps with queries I can solve this Problem, or what do you think?
I am thankful for each tip! =)
you can you use below code: this will copy the datesheet view in your form and copy paste it in to one excel file .For this you just drag one sub form control from tool box in to your form and set the property of this sub form's source data as your query name and replace the sub form name in the code
Private Sub Command48_Click()
On Error GoTo Command13_Click_Err
Me.subformName.SetFocus
'DoCmd.GoToControl "Policy Ref"
DoCmd.RunCommand acCmdSelectAllRecords
DoCmd.RunCommand acCmdCopy
Dim xlapp As Excel.Application
Set xlapp = CreateObject("Excel.Application")
With xlapp
.Workbooks.Add
.ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:= _
False
.Cells.Select
.Cells.EntireColumn.AutoFit
.Visible = True
.Range("a1").Select
End With
Command13_Click_Exit:
Exit Sub
Command13_Click_Err:
MsgBox Error$
Resume Command13_Click_Exit
End sub
'=======================
you can you use below code: this will copy the datesheet view in your form and copy paste it in to one excel file .For this you just drag one sub form control from tool box in to your form and set the property of this sub form's source data as your query name and replace the sub form name in the code
Private Sub Command48_Click()
On Error GoTo Command13_Click_Err
Me.subformName.SetFocus
'DoCmd.GoToControl "Policy Ref"
DoCmd.RunCommand acCmdSelectAllRecords
DoCmd.RunCommand acCmdCopy
Dim xlapp As Excel.Application
Set xlapp = CreateObject("Excel.Application")
With xlapp
.Workbooks.Add
.ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:= _
False
.Cells.Select
.Cells.EntireColumn.AutoFit
.Visible = True
.Range("a1").Select
End With
Command13_Click_Exit:
Exit Sub
Command13_Click_Err:
MsgBox Error$
Resume Command13_Click_Exit
End sub
'''PPT
Sub pptExoprort()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim slideNum As Integer
Dim chartName As String
Dim tableName As String
Dim PPTCount As Integer
Dim PPSlideCount As Long
Dim oPPTShape As PowerPoint.Shape
Dim ShpNm As String
Dim ShtNm As String
Dim NewSlide As String
Dim myChart As PowerPoint.Chart
Dim wb As Workbook
Dim rngOp As Range
Dim ro As Range
Dim p As Integer
Dim v, v1, v2, v3, Vtot, VcaGr
Dim ws As Worksheet
Dim ch
Dim w As Worksheet
Dim x, pArr
Dim rN As String
Dim rt As String
Dim ax
Dim yTbN As String
'Call InitializeGlobal
''start year offset
prodSel = shtSet.Range("rSelProd")
x = shtSet.Range("rngMap").Value
pArr = fretPrVal(x, prodSel)
TY = 11 'number of years in chart
ThisWorkbook.Activate
Set w = ActiveSheet
Set PPApp = GetObject("", "Powerpoint.Application") '******************
PPTCount = PPApp.Presentations.Count
If PPTCount = 0 Then
MsgBox ("Please open a PPT to export the Charts!")
Exit Sub
End If
Set PPPres = PPApp.ActivePresentation '******************
For j = 0 To UBound(pArr)
If j = 0 Then
rN = "janport"
slideNum = 3
yTbN = "runport"
Else
rN = "janprod" & j
slideNum = 3 + j
yTbN = "runprod" & j
End If
chartName = "chtSalesPort"
Set PPSlide = PPPres.Slides(slideNum) '**************
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
Set myChart = PPSlide.Shapes(chartName).Chart '******************
myChart.ChartData.Activate '********************
Set wb = myChart.ChartData.Workbook '***********
Set ws = wb.Worksheets(1) '**************
Set rngOp = w.Range(rN).Offset(0, 1).Resize(12, 6)
Set ro = rngOp
' v1 = ro.Offset(1, 22).Resize(Lc, 1)
'ws.ListObjects("Table1").Resize Range("$A$1:$B$" & Ty + 1)
'ws.ListObjects("Table1").Resize Range("$A$1:$" & Chr(Lc + 1 + 64) & "$" & Ty + 1)
ws.Range("B2:g13").ClearContents '***********
rngOp.Copy '**********
ws.Range("B2:g13").PasteSpecial xlPasteValues '******************
End Sub
Sub Picture62_Click()
Dim charNamel As String
Dim leftm As Integer
Dim toptm As Integer
charNamel = "Chart 1"
leftm = 35
toptm = 180
Call chartposition(leftm, toptm, charNamel)
End Sub
Sub chartposition(leftm, toptm, charNamel)
ActiveSheet.ChartObjects(charNamel).Activate
'First we declare the variables we will be using
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
Dim activslidenumber As Integer
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
' If newPowerPoint.Presentations.Count = 0 Then
' newPowerPoint.Presentations.Add
' End If
'Show the PowerPoint
newPowerPoint.Visible = True
On Error GoTo endd:
activslidenumber = Str(GetActiveSlide(newPowerPoint.ActiveWindow).SlideIndex)
Set activeSlide = newPowerPoint.ActivePresentation.Slides(activslidenumber)
ActiveChart.ChartArea.Copy
On Error GoTo endddd:
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteDefault).Select
'activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
'activeSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, DisplayAsIcon:=msoFalse).Select
endddd:
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = leftm
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = toptm
GoTo enddddd:
endd:
MsgBox ("Please keep your PPT file opened")
enddddd:
End Sub
I have created a code with vba which copy data from excel sheet and paste the same as picture in powerpoint slide, but its not working exactly as per my need.
It should copy data from each worksheets and paste it in a given powerpoint slide worksheet wise. Measn worksheet 1 data should be copied in slide 1 followed by worksheet 2 data in slide 2 and so on and at the end it should save the created ppt file.
But my code is copying and pasting all worksheets data overlaping each other in all the slides of the powerpoint.
Since i am new to vba i am not sure where i am going wrong with the below code:
Sub WorkbooktoPowerPoint()
Dim xlwksht As Worksheet
Dim MyRange As String
Dim MyRange1 As String 'Define another Range
Dim MyTitle As String
Dim oPPTApp As PowerPoint.Application
Dim oPPTShape As PowerPoint.Shape
Dim oPPTFile As PowerPoint.Presentation
Dim SlideNum As Integer
Dim oSlide As Slide
Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String
strPresPath = "C:\Users\FYI\PPT1.pptx"
strNewPresPath = "C:\Users\FYI\new1.pptx"
Set oPPTApp = CreateObject("PowerPoint.Application")
oPPTApp.Visible = msoTrue
Set oPPTFile = oPPTApp.Presentations.Open(strPresPath)
For Each oSlide In oPPTFile.Slides
i = oSlide.SlideNumber
oSlide.Select
MyRange = "B2:B5"
MyRange1 = "B8:B11"
For Each xlwksht In ActiveWorkbook.Worksheets
xlwksht.Select Application.Wait(Now + TimeValue("0:00:1"))
xlwksht.Range(MyRange).CopyPicture Appearance:=xlScreen, Format:=xlPicture
oSlide.Shapes.Paste.Select
oPPTApp.ActiveWindow.Selection.ShapeRange.Align msoAlignTops, True
oPPTApp.ActiveWindow.Selection.ShapeRange.Top = 65
oPPTApp.ActiveWindow.Selection.ShapeRange.Left = 7.2
oPPTApp.ActiveWindow.Selection.ShapeRange.Width = 400
xlwksht.Range(MyRange1).CopyPicture Appearance:=xlScreen, Format:=xlPicture
oSlide.Shapes.Paste.Select
oPPTApp.ActiveWindow.Selection.ShapeRange.Align msoAlignBottoms, True
oPPTApp.ActiveWindow.Selection.ShapeRange.Top = 250
oPPTApp.ActiveWindow.Selection.ShapeRange.Left = 7.2
oPPTApp.ActiveWindow.Selection.ShapeRange.Width = 400
Next xlwksht
Next
oPPTApp.Activate
oPPTFile.SaveAs strNewPresPath
oPPTFile.Close
oPPTApp.Quit
Set oPPTShape = Nothing
Set oPPTFile = Nothing
Set oPPTApp = Nothing
MsgBox "Presentation Created", vbOKOnly + vbInformation
End Sub
Please give this a shot. The main change is that I removed the For Each loop. You are already looping through the slides of the deck and can use the slide number to reference the Excel worksheet (they are numbered, as well). It was creating a mess, now it runs smoothly.
Sub WorkbooktoPowerPoint()
Dim xlwksht As Worksheet
Dim MyRange As String
Dim MyRange1 As String 'Define another Range
Dim oPPTApp As PowerPoint.Application
Dim oPPTShape As PowerPoint.Shape
Dim oPPTFile As PowerPoint.Presentation
Dim SlideNum As Integer
Dim oSlide As Slide
Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String
strPresPath = "C:\Users\FYI\PPT1.pptx"
strNewPresPath = "C:\Users\FYI\new1.pptx"
Set oPPTApp = CreateObject("PowerPoint.Application")
oPPTApp.Visible = msoTrue
Set oPPTFile = oPPTApp.Presentations.Open(strPresPath)
For Each oSlide In oPPTFile.Slides
i = oSlide.SlideNumber
' The following line was added after the OPs follow-up
If i > ActiveWorkbook.Sheets.Count Then Exit For
oSlide.Select
MyRange = "B2:B5"
MyRange1 = "B8:B11"
With ActiveWorkbook.Sheets(i)
.Range(MyRange).CopyPicture Appearance:=xlScreen, Format:=xlPicture
oSlide.Shapes.Paste.Select
With oPPTApp
.ActiveWindow.Selection.ShapeRange.Align msoAlignTops, True
.ActiveWindow.Selection.ShapeRange.Top = 65
.ActiveWindow.Selection.ShapeRange.Left = 7.2
.ActiveWindow.Selection.ShapeRange.Width = 400
End With
.Range(MyRange1).CopyPicture Appearance:=xlScreen, Format:=xlPicture
oSlide.Shapes.Paste.Select
With oPPTApp
.ActiveWindow.Selection.ShapeRange.Align msoAlignBottoms, True
.ActiveWindow.Selection.ShapeRange.Top = 250
.ActiveWindow.Selection.ShapeRange.Left = 7.2
.ActiveWindow.Selection.ShapeRange.Width = 400
End With
End With
Next
oPPTApp.Activate
oPPTFile.SaveAs strNewPresPath
oPPTFile.Close
oPPTApp.Quit
Set oPPTShape = Nothing
Set oPPTFile = Nothing
Set oPPTApp = Nothing
MsgBox "Presentation Created", vbOKOnly + vbInformation
End Sub
I'm kind of stuck on this code
I need a powerpoint macro which allows me to save all powerpoint files to a particular map with as name "name of presentation" + variable. Anybody a clue whats wrong with code below?
Sub save()
Dim i As Integer
Dim pptcount As Integer
Dim pres As Presentation
Dim var1 As String
Set pres = Application.Presentations(i)
var1 = InputBox("geef hier je maand aan")
pptcount = Application.Presentations.Count
For i = 1 To pptcount
Application.ActivePresentation.SaveAs "X:\SSC_HR\SENS\Bedrijfsbureau\Rapportages\SENS referenten rapportage\Template_Uploaden\" & var1 & ".ppt"
Next
End Sub
Try this code:
Sub save()
Dim pres As Presentation
Dim var1 As String
var1 = InputBox("geef hier je maand aan")
If var1 <> "" Then
For Each pres In Application.Presentations
pres.SaveAs "X:\SSC_HR\SENS\Bedrijfsbureau\Rapportages\SENS referenten rapportage\Template_Uploaden\" & Split(pres.Name, ".")(0) & var1 & ".ppt"
Next
End If
End Sub
I have a macro that basically is supposed to copy ranges from excel spreadsheets and then paste them into a powerpoint file. So one excel sheet per slide.
Here is my macro so far:
Option Explicit
Sub ExportToPPT()
Dim PPAPP As PowerPoint.Application
Dim PPRES As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim ppSRng As PowerPoint.ShapeRange
Dim XLAPP As Excel.Application
Dim XLwbk As Excel.Workbook
Dim xlWst As Excel.Worksheet
Dim XLRng As Excel.Range
Dim ppPathFile As String
Dim ppNewPathFile
Dim chartNum As Integer
Dim maxCharts As Integer
Debug.Print vbCrLf & " ---- EXPORT EXCEL RANGES POWERPOINT ----"
Debug.Print Now() & " - Exporting ranges to .ppt"
'CHANGE WHEN ADDING CHARTS - MUST ALSO ADD SLIDE to .PPT and change loop
Dim chartRng(1 To 9) As Excel.Range
Dim SlideNum As Integer
Dim SlideOffset As Integer
Set XLwbk = Excel.ActiveWorkbook
Set xlWst = XLwbk.Sheets("Test1")
'This accounts for the title slide and any others before the automatedpaste
SlideOffset = 1
Set chartRng(1) = XLwbk.Sheets("Test1").Range("A1:B15")
Set chartRng(2) = XLwbk.Sheets("Test2").Range("A1:E33")
Set chartRng(3) = XLwbk.Sheets("Test3").Range("A1:E33")
Set chartRng(4) = XLwbk.Sheets("Test4").Range("A1:E4")
Set chartRng(5) = XLwbk.Sheets("Test5").Range("A1:J14")
Set chartRng(6) = XLwbk.Sheets("Test6").Range("A1:I33")
Set chartRng(7) = XLwbk.Sheets("Test7").Range("A1:I11")
Set chartRng(8) = XLwbk.Sheets("Test8").Range("A1:I8")
' Create instance of PowerPoint
Set PPAPP = CreateObject("Powerpoint.Application")
PPAPP.Visible = True
' Open the presentation (Same folder as the Excel file)
ppPathFile = ActiveWorkbook.Path + "TestPPT.pptx"
Debug.Print ppPathFile
Set PPRES = PPAPP.Presentations.Open(ppPathFile)
PPAPP.ActiveWindow.ViewType = ppViewSlide
chartNum = 1
'Loop through all chart ranges
'CHANGE WHEN ADDING CHARTS
For chartNum = 1 To 9
SlideNum = chartNum + SlideOffset
Debug.Print "Chart number " & chartNum & " to slide number " & SlideNum
' Copy the range as a picture
chartRng(chartNum).CopyPicture Appearance:=xlScreen, Format:=xlPicture
'PowerPoint operations
Set PPSlide = PPAPP.ActivePresentation.AddSlide(1, _ **//New code**
PPAPP.ActivePresentation.SlideMaster.CustomLayouts.Item(2))
Debug.Print PPSlide.Name
PPSlide.Select
PPAPP.ActiveWindow.ViewType = ppViewSlide
'ppapp.ActivePresentation.Slides.
' Paste the range
'PPAPP.ActiveWindow.View.Slide (SlideNum)
PPAPP.ActiveWindow.View.Paste
'PPSlide.Shapes.Paste
'PPSlide.Shapes(0).Select
'PPSlide.Shapes.Paste.Select
' Align the pasted range
Set ppSRng = PPAPP.ActiveWindow.Selection.ShapeRange
With ppSRng
.LockAspectRatio = msoTrue
If (.Width / .Height) > 1.65 Then
.Width = 650
Else
.Height = 400
End If
End With
With ppSRng
'.Width = 650
.Align msoAlignCenters, True
.Align msoAlignMiddles, True
.IncrementTop 1.5
End With
Next chartNum
PPAPP.ActivePresentation.Slides(1).Select
PPAPP.ActiveWindow.ViewType = ppViewNormal
PPAPP.Activate
ppNewPathFile = ActiveWorkbook.Path & "\Test\TestPPT.pptx" & Format(Now(), "yyyymmdd_hhmmss")
PPAPP.ActivePresentation.SaveAs ppNewPathFile, ppSaveAsDefault
Debug.Print Now() & " - Finished"
End Sub
When I run the Macro it opens PowerPoint but stops and I get the following Error:
And when I debug it stops at this line:
Set PPSlide = PPAPP.ActivePresentation.Slides(SlideNum)
Any help on how to fix this would be great guys.
The error points to a counting problem that you've introduced in your code. Apparently, during the first iteration, it attempts to choose the second slide of a one-slide presentation (the second slide does not exist) and throwing an error.
I would assume this occurs because of your SlideOffset variable. Consider first adding a slide using before running Set PPSlide = PPAPP.ActivePresentation.Slides(SlideNum). Something like this:
Set pptLayout = PPAPP.ActivePresentation.Slides(1).CustomLayout
Set pptSlide = PPAPP.ActivePresentation.Slides.AddSlide(2, pptLayout)
Try using this
Set PPSlide = PPAPP.ActivePresentation.AddSlide(1, _
PPAPP.ActivePresentation.SlideMaster.CustomLayouts.Item(2))