I use VBA to export data from XL to PPT. In windows it works fine. But When I use same code in MAC OS. I get error in this line..
Set pPres = pptApp.Presentations.Open(currentPath & Application.PathSeparator & pptname, msoFalse, msoCTrue, msoCTrue)
Dim pptApp As Object
Dim pPres As Object
Dim xl As Excel.Workbooks
Dim ws As Worksheet
Dim sldrange As Object
Dim sld As Object
Dim pattrenSlide As Object
Dim WorkSheetRange As Range
Sub Export()
'both file names and path
Dim wkname, pptname, currentPath As String
'Other Values
pptname = "Template.pptx"
currentPath = ThisWorkbook.Path
'Ópening Powerpoint
Set pptApp = CreateObject("Powerpoint.Application")
Set pPres = pptApp.Presentations.Open(currentPath & Application.PathSeparator & pptname, msoFalse, msoCTrue, msoCTrue)
'Opening Excel
Set wk = ThisWorkbook
Can anyone help me please?
Related
I tried to run the following macro. Seems to work (I don`t have any error) but in the end only an empty folder opens (no picture exported). Please, help me with any advice! I am a beginner in VBA. Thank you very much!
Sub ExportAllCharts()
Dim objShell As Object
Dim objWindowsFolder As Object
Dim strWindowsFolder As String
Dim objSheet As Excel.Worksheet
Dim objChartObject As Excel.ChartObject
Dim objChart As Excel.Chart
'Select a Windows folder
Set objShell = CreateObject("Shell.Application")
Set objWindowsFolder = objShell.BrowseForFolder(0, "Select a Windows folder:", 0, "")
If Not objWindowsFolder Is Nothing Then
strWindowsFolder = objWindowsFolder.self.Path & "\"
For i = ThisWorkbook.Worksheets.Count To 1 Step -1
Set objSheet = ThisWorkbook.Worksheets(i)
If objSheet.ChartObjects.Count > 0 Then
For Each objChartObject In objSheet.ChartObjects
Set objChart = objChartObject.Chart
objChart.Export strWindowsFolder & objChart.Name & ".png"
Next
End If
Next
'Open the windows folder
Shell "Explorer.exe" & " " & strWindowsFolder, vbNormalFocus
End If
End Sub
Source code link
Now I`m trying to find a solution to export all the charts with the worksheet name + a suffix.
I wish I could insert the desired suffix (the same for all worksheets) into a pop-up window.
I have this code that renames all the worksheets, but I need to adapt it to rename them only partially. I thought maybe I could incorporate it into the initial macro.
Sub ChangeWorkSheetName()
Dim Rng As Range
Dim WorkRng As Range
On Error Resume Next
xTitleId = "Write the new Worksheets Name"
NewName = Application.InputBox("Name", xTitleId, "", Type:=2)
j = 1
For i = 1 To Application.Sheets.Count
If Application.Sheets(i).Visible Then
Application.Sheets(i).Name = NewName & j
j = j + 1
End If
Next
End Sub
Can anyone give me a suggestion? Thank you very much!
If you need to include charts on chart sheets you need a second loop:
Sub ExportAllCharts()
Dim objShell As Object
Dim objWindowsFolder As Object
Dim strWindowsFolder As String
Dim objSheet As Excel.Worksheet
Dim objChartObject As Excel.ChartObject
Dim objChart As Excel.Chart
'Select a Windows folder
Set objShell = CreateObject("Shell.Application")
Set objWindowsFolder = objShell.BrowseForFolder(0, "Select a Windows folder:", 0, "")
If Not objWindowsFolder Is Nothing Then
strWindowsFolder = objWindowsFolder.self.Path & "\"
'charts on chart sheets
For Each objChart In ThisWorkbook.Charts
objChart.Export strWindowsFolder & objChart.Name & ".png"
Next objChart
'chartobjects (on worksheets)
For Each objSheet In ThisWorkbook.Worksheets
For Each objChartObject In objSheet.ChartObjects
With objChartObject.Chart
.Export strWindowsFolder & .Name & ".png"
End With
Next
Next
'Open the windows folder
Shell "Explorer.exe" & " " & strWindowsFolder, vbNormalFocus
End If
End Sub
This was working fine, only sometimes I get this error, but it is happening more and more. Like it will work one a group of invoices, I will try it agian and it works on like half of them the next time. It is breaking at the .Paste Just cant firgure out what it is. I am converting PDF to Excel. This method has given me the best results so for and all my other code that works from the output is already writtten
Sub PDF_To_Excel()
Dim automate_sh As Worksheet
Set automate_sh = ThisWorkbook.Sheets("Automate")
Dim pdf_path As String
Dim excel_path As String
pdf_path = automate_sh.Range("E11").Value
excel_path = automate_sh.Range("E12").Value
Dim fso As New FileSystemObject
Dim fo As Folder
Dim f As File
Set fo = fso.GetFolder(pdf_path)
Dim wa As Object
Dim doc As Object
Dim wr As Object
Set wa = CreateObject("word.application")
wa.Visible = True
Dim nwb As Workbook
Dim nsh As Worksheet
For Each f In fo.Files
Set doc = wa.documents.Open(f.Path, False, Format:="PDF Files")
Set wr = doc.Paragraphs(1).Range
wr.WholeStory
Set nwb = Workbooks.Add
Set nsh = nwb.Sheets(1)
wr.Copy
nsh.Paste
nwb.SaveAs (excel_path & "\" & Replace(f.Name, ".pdf", ".xlsx"))
doc.Close False
nwb.Close False
Next
wa.Quit
MsgBox "Done"
End Sub
I have a little issue with my macro. I know it's not the perfect one but at least it works.
The only thing is that when I go step by step it is going perfectly but when I run it all the new slides are blank.
Do you have an idea how to improve that ?
Sub paste_toPPT()
Dim PowerPointApp As Object
Dim pptApp As Object
Dim pptPres As Object
Dim myRange As Excel.Range
Dim path As String
Dim DestinationPPT As String
Dim saveName As String
Dim image As Object
Dim IDe As String
Dim count As Integer
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set pptApp = GetObject(Class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If pptApp Is Nothing Then Set pptApp = CreateObject(Class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Open template
DestinationPPT = "C:\Users\user\Desktop\ID Card\Kpi ID.pptx"
Set pptPres = pptApp.Presentations.Open(DestinationPPT)
Windows("KPI List - P2P KPI.xlsm").Activate
count = WorksheetFunction.CountA(Sheets("KPI List").Range("E:E")) - 1
For i = 8 To count
Worksheets("KPI List").Select
'ThisWorkbook.Sheets("KPI List").Select
IDe = Worksheets("KPI List").Range(Cells(i, 5), Cells(i, 5))
ThisWorkbook.Sheets("ID").Range("F4:F4") = IDe
'Set the range to copy
Windows("KPI List - P2P KPI.xlsm").Activate
Worksheets("ID").Select
Worksheets("ID").Shapes.Range(Array("Group 57")).Select
Selection.Copy
'Add slide & Paste data
pptPres.Windows(1).Activate
Set mySlide = pptPres.Slides.Add(1, 12)
mySlide.Select
pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
Next i
pptPres.SaveAs DestinationPPT
End Sub
Try the code below, explanations inside the code as comments:
Sub paste_toPPT()
Dim pptApp As Object
Dim pptPres As Object
Dim myRange As Excel.Range
Dim path As String
Dim DestinationPPT As String
Dim saveName As String
Dim image As Object
Dim IDe As String
Dim count As Integer
' added 2 worksheet objects
Dim wsKPI As Worksheet
Dim wsID As Worksheet
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set pptApp = GetObject(, "PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If pptApp Is Nothing Then Set pptApp = CreateObject("PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Open template
DestinationPPT = "C:\Users\user\Desktop\ID Card\Kpi ID.pptx"
Set pptPres = pptApp.Presentations.Open(DestinationPPT)
' no need to Activate the workbook first, just set the worksheet objects
Set wsKPI = Workbooks("KPI List - P2P KPI.xlsm").Sheets("KPI List")
Set wsID = Workbooks("KPI List - P2P KPI.xlsm").Sheets("ID")
count = WorksheetFunction.CountA(ws.Range("E:E")) - 1
For i = 8 To count
IDe = wsKPI.Range(wsKPI.Cells(i, 5), wsKPI.Cells(i, 5))
wsID.Range("F4:F4") = IDe
' first add the slide , later do the copy>>paste as close as can be
Set mySlide = pptPres.Slides.Add(1, 12)
' Set the range to copy (no need to Select first)
wsID.Shapes.Range(Array("Group 57")).Copy
mySlide.Select
pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
Next i
pptPres.Save
End Sub
I am creating a PowerPoint each week from some charts in Excel using VBA. However, the first slide needs to come from lasts week PowerPoint created.
The file path and name are both variables because they have the date in their title. I am able to account for this and have checked it with the actual file's name. It looks the same to me. However when I try to Open the file I get the ActiveX error/Run-time error 429. Any ideas would be much appreciated
Sub CreateNewPres()
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim objPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide
Dim ppTextbox As PowerPoint.Shape
Set ppApp = New PowerPoint.Application
ppApp.Visible = True
ppApp.Activate
Set ppPres = ppApp.Presentations.Add
todayDate = Date
myTextDate = Format(todayDate, "yyyy-mm-dd")
myFilePath = "C:\Desktop\Main\" & myTextDate
myFileName = "\Meeting_" & myTextDate & ".pptx"
myFile = myFilePath & myFileName
objPres=_
Presentations.Open(myFile)
objPres.Slides(1).Copy
ppPres.Slides.Paste (ppPasteEnchancedMetafile)
Set ppTextbox = ppSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, _
Left:=0, Top:=0, Width:=30, Height:=10)
With myTextBox.TextFrame.TextRange.Text = todayDate
End With
Change this line:
objPres = Presentations.Open(myFile)
to this:
Set objPres = ppApp.Presentations.Open(myFile)
The Excel hang if the user click the button in the sheet. The button allowed the user to run the following VBA code. If the user runs the code from VBA editor, it's working fine. Kindly help. The code is as the following. I'm trying to copy data from current excel file to the other excel file newly created.
Sub clickBreak()
i = 12
Dim workBookName As String
Dim workBookName2 As String
Dim wb2 As Workbook
Dim wb1 As Workbook
Dim pasteStart As Range
workBookName = Application.ActiveWorkbook.FullName
workBookName2 = Insert(workBookName, "_2", InStr(workBookName, ".xls") - 1) & ".xls"
MsgBox workBookName2
Dim xlobj As Object
Set xlobj = CreateObject("Scripting.FileSystemObject")
xlobj.CopyFile workBookName, workBookName2, True
Set xlobj = Nothing
Set wb1 = Workbooks.Open(Filename:=workBookName)
Set pasteStart = [A12:A15]
wb1.Sheets("contents").Range("A12:A15").Copy
Set wb2 = Workbooks.Open(Filename:=workBookName2)
wb2.Sheets("contents").Range("A12:A:15").PasteSpecial xlPasteAll
wb2.Save
End Sub
clickBreak is not an event handler. If the name of your button is Break you must name the sub
BreaK_Click() for it to act as an event handler for the button click event:
Sub BreaK_Click()
...
End Sub
Full Code:
Sub BreaK_Click()
i = 12
Dim workBookName As String
Dim workBookName2 As String
Dim wb2 As Workbook
Dim wb1 As Workbook
Dim pasteStart As Range
workBookName = Application.ActiveWorkbook.FullName
workBookName2 = Insert(workBookName, "_2", InStr(workBookName, ".xls") - 1) & ".xls"
MsgBox workBookName2
Dim xlobj As Object
Set xlobj = CreateObject("Scripting.FileSystemObject")
xlobj.CopyFile workBookName, workBookName2, True
Set xlobj = Nothing
Set wb1 = Workbooks.Open(Filename:=workBookName)
Set pasteStart = [A12:A15]
wb1.Sheets("contents").Range("A12:A15").Copy
Set wb2 = Workbooks.Open(Filename:=workBookName2)
wb2.Sheets("contents").Range("A12:A:15").PasteSpecial xlPasteAll
wb2.Save
End Sub
I got the answer
Sub clickBreak()
Dim workBookName As String
Dim workBookName2 As String
Dim wbTarget As Workbook
Dim wbThis As Workbook
Dim strName As String
Set wbThis = ActiveWorkbook
strName = ActiveSheet.Name
workBookName = Application.ActiveWorkbook.FullName
workBookName2 = Insert(workBookName, "_2", InStr(workBookName, ".xls") - 1) & ".xls"
Dim xlobj As Object
Set xlobj = CreateObject("Scripting.FileSystemObject")
xlobj.CopyFile workBookName, workBookName2, True
Set xlobj = Nothing
Set wbTarget = Workbooks.Open(workBookName2)
wbTarget.Sheets("contents").Range("A1").Select
wbTarget.Sheets("contents").Range("A12:A15").ClearContents
wbThis.Activate
Application.CutCopyMode = False
wbThis.Sheets("contents").Range("A12:A15").Copy
wbTarget.Sheets("contents").Range("A12:A15").PasteSpecial
Application.CutCopyMode = False
wbTarget.Save
wbTarget.Close
wbThis.Activate
'clear memory
Set wbTarget = Nothing
Set wbThis = Nothing
End Sub
Thanks you for spending time on my question and giving feedback. Sorry for answering my own question, I just want to share my resolution with the other who will be having the same problem.
I got reference from this http://en.kioskea.net/faq/24666-excel-vba-copy-data-to-another-workbook