So when you right click a chart in Powerpoint and click Edit Data. A workbook will open up. I just want those data to be copied to my Excel file. Help me to extract every chart in each slide of powerpoint. Please help me Here's my code in PPT VBA so far:
Sub PowerpointToExcel()
Dim PPTPres As Presentation
Dim PPTSlide As Slide
Dim PPTShape As Shape
Dim PPTTable As Table
Dim PPTChart As Chart
Dim PPTPlaceHolder As PlaceholderFormat
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlRange As Excel.Range
Dim PPTChartData As MSForms.DataObject
Set PPTPres = Application.ActivePresentation
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
Set xlBook = xlApp.Workbooks("Book2.xlsx")
Set xlSheet = xlBook.Worksheets("Sheet2")
Set PPTChartData = New MSForms.DataObject
For Each PPTSlide In PPTPres.Slides
For Each PPTShape In PPTSlide.Shapes
If PPTShape.HasChart Then
Set PPTChart = PPTShape.Chart
Set xlRange = xlSheet.Range("A10000").End(xlUp)
If xlRange.Value <> "" Then
Set xlRange = xlRange.Offset(1, 0)
End If
With PPTPres.Slides(PPTSlide).Shapes(PPTShape).Chart.ChartData
.Activate
.Workbook.Sheets(1).Range("A2:E10").Copy
PPTChartData.GetFromClipboard
End With
SData = PPTChartData.GetText(1)
xlRange.Value = SData
xlRange.Offset(0, 1).Value = PPTSlide.Name
xlRange.Offset(0, 2).Value = PPTChart.ChartData
End If
Next
Next
End Sub
Related
The below code extracts data from the active PowerPoint presentation.
Sub ExportMultiplePowerPointSlidesToExcel()
'Declare our Variables
Dim ppApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
Dim PPTShape As PowerPoint.Shape
Dim PPTTable As PowerPoint.Table
Dim PPTPlaceHolder As PowerPoint.PlaceholderFormat
'Declare Excel Variables.
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlWrkSheet As Excel.Worksheet
Dim xlRange As Excel.Range
'Grab the Currrent Presentation.
Set ppApp = GetObject(, "PowerPoint.Application")
Set PPTPres = ppApp.ActivePresentation
Set PPTSlide = PPTPres.Slides(1)
'Grab the Currrent Presentation.
'Keep going if there is an error
On Error Resume Next
'Get the Active instance of Outlook if there is one
Set xlApp = GetObject(, "Excel.Application")
'If Outlook isn't open then create a new instance of Outlook
If Err.Number = 429 Then
'Clear Error
Err.Clear
'Create a new Excel App.
Set xlApp = New Excel.Application
'Make sure it's visible.
xlApp.Visible = True
'Add a new workbook.
Set xlBook = xlApp.Workbooks.Add
'Add a new worksheet.
Set xlWrkSheet = xlBook.Worksheets.Add
End If
'Set the Workbook to the Active one, if Excel is already open. THIS ASSUMES WE HAVE A WORKBOOK IN THE EXCEL APP.
Set xlBook = Workbooks("Cycle 2 - FSO Dirs and EDs - CCG Talent Review template.xlsm")
'Set the Worksheet to the Active one, if Excel is already open. THIS ASSUMES WE HAVE A WORKSHEET IN THE WORKBOOK.
Set xlWrkSheet = xlBook.Worksheets("CCG list")
Range("B3").Value = PPTSlide.Shapes(4).TextFrame.TextRange
Range("E3").Value = PPTSlide.Shapes(7).TextFrame.TextRange
'Set the Worksheet Column Width.
xlWrkSheet.Columns.ColumnWidth = 20
'Set the Worksheet Row Height.
xlWrkSheet.Rows.RowHeight = 20
'Set the Horizontal Alignment so it's to the Left.
xlWrkSheet.Cells.HorizontalAlignment = xlLeft
'Turn off the Gridlines.
xlApp.ActiveWindow.DisplayGridlines = False
End Sub
How do I loop through the presentations in the current directory to perform the action?
I have attempted numerous methods but I can't seem to indicate each presentation. The name of the presentation should be irrelevant.
I am facing the following issue: I have an open excel-file as well as an open Powerpoint file. I want to select and copy two different ranges in Excel (range1: B4:D9, range 2: F4:H10") into two shapes (tables) in my powerpoint (range1 into Shape 16, range2 into Shape 20). When I run the subs for range1 and range2 in debug mode after each other everything works and the data is pasted correctly in Powerpoint. When I create one button for each range and use the button to execute the code its also working fine.
My problem: I would like to use the following code to call both codes for range1 and range2 to create only one button for this. When I run the sub below (UpdateSlide) the code pastes range F4:H10 into both Shapes 16 & 20 and I dont understand why. I am quite new to VBA so I appreciate every help to fix this. Many thanks in advance!
`Sub UpdateSlide()
Call range1
Call range2
End Sub`
Please see here for the two codes for range1 as well as range2:
`Sub range1()
'Range1 in Excel
Dim range1 As Excel.range
Dim sheet As Excel.Worksheet
Dim excelApp As Excel.Application
Set excelApp = GetObject(, "Excel.Application")
Set sheet = excelApp.ActiveWorkbook.Sheets("Sheet1")
sheet.Activate
Set range1 = sheet.range("B4:D9")
range1.Select
range1.Copy
'Tabelle in Powerpoint auswählen
Dim table1 As Powerpoint.Shape
Dim pptApp As Powerpoint.Application
Set pptApp = GetObject(, "Powerpoint.Application")
pptApp.Activate
Dim slide As Powerpoint.slide
Set slide = pptApp.ActiveWindow.View.slide
Set table1 = slide.Shapes(16)
table1.table.Cell(1, 1).Select
'Daten einkopieren - ohne das Format verändert wird
pptApp.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting"
sheet.Activate
Set range1 = Nothing
Set sheet = Nothing
Set excelApp = Nothing
Set table1 = Nothing
Set pptApp = Nothing
Set slide = Nothing
End Sub
Sub range2()
'Range2 in Excel
Dim range2 As Excel.range
Dim sheet As Excel.Worksheet
Dim excelApp As Excel.Application
Set excelApp = GetObject(, "Excel.Application")
Set sheet = excelApp.ActiveWorkbook.Sheets("Sheet1")
sheet.Activate
Set range2 = sheet.range("F4:H10")
range2.Select
range2.Copy
'Tabelle in Powerpoint auswählen
Dim table2 As Powerpoint.Shape
Dim pptApp As Powerpoint.Application
Set pptApp = GetObject(, "Powerpoint.Application")
pptApp.Activate
Dim slide As Powerpoint.slide
Set slide = pptApp.ActiveWindow.View.slide
Set table2 = slide.Shapes(20)
table2.table.Cell(1, 1).Select
'Daten einkopieren - ohne das Format verändert wird
pptApp.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting"
Set range2 = Nothing
Set sheet = Nothing
Set excelApp = Nothing
Set table2 = Nothing
Set pptApp = Nothing
Set slide = Nothing
End Sub`
I'm new to VBA and I'm having difficulty trying to insert comments from data that I have in Excel onto a Word document. I am trying to write the VBA in Word and want it to extract data from a separate spreadsheet
Sub ConvertCelltoWordComment()
Dim Rng As Range
Dim wApp As Object
Dim strValue As String
Dim xlapp As Object
Dim xlsheet As Object
Dim xlbook As Object
'Opens Excel'
Set xlapp = GetObject("C:\Users\eugenechang\Desktop\...xlsx")
If Err Then
Set xlapp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Dim i As Integer
For i = 1 To 5
With xlsheet
strValue = ActiveSheet.Cells(i, 1).Offset(1, 0)
End With
'Insert comment into document'
ActiveDocument.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:="15"
ActiveDocument.Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative, Count:=5
ActiveDocument.Comments.Add Range:=Selection.Range, Text:=strValue
Next i
End Sub
I'm trying to get it to work, but it is giving me an error "Object not defined". I've tried setting up an object within the strValue line below "With xlsheet", but am hitting a wall. Any help??
You have not assigned anything to xlsheet - so this (by default) equates to Nothing.
Try setting xlSheet to something meaningful. The following is only an example:
For i = 1 To 5
Set xlsheet = xlbook.Worksheets(i) ' <--- example here
With xlsheet
strValue = .Cells(i, 1).Offset(1, 0) '<-- don't use ActiveSheet
End With
'Insert comment into document'
ActiveDocument.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:="15"
ActiveDocument.Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative, Count:=5
ActiveDocument.Comments.Add Range:=Selection.Range, Text:=strValue
Next I
An important note here is that you also have not set xlbook - you must also assign something meaningful to xlbook.
Add a couple DocVariables to your Word file and run the script below, from Excel.
Sub PushToWord()
Dim objWord As New Word.Application
Dim doc As Word.Document
Dim bkmk As Word.Bookmark
sWdFileName = Application.GetOpenFilename(, , , , False)
Set doc = objWord.Documents.Open(sWdFileName)
'On Error Resume Next
objWord.ActiveDocument.variables("FirstName").Value = Range("FirstName").Value
objWord.ActiveDocument.variables("LastName").Value = Range("LastName").Value
' etc., etc., etc.
objWord.ActiveDocument.Fields.Update
'On Error Resume Next
objWord.Visible = True
End Sub
This ended up writing comments from an Excel file. Obviously the names have been changed for privacy reasons. Please let me know if I can simplify this better.
Sub ConvertExceltoWordComment()
Dim wApp As Word.Application
Dim xlApp As Excel.Application
Dim PgNum As Integer
Dim LineNum As Integer
Dim objSelection As Word.Document
Dim strpgSearch As Long
Dim strlinSearch As Long
Dim myRange As Range
Dim XlLog As Excel.Worksheet
Dim RowCount As Long
'Opens Copied Word document'
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
If Err Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Dim SaveDoc As Excel.Workbook
Set SaveDoc = xlApp.Workbooks.Open("FilePath.xlsm") 'Type filepath of document here'
Set XlLog = SaveDoc.Sheets("Worksheet_Name") 'Type Sheetname here'
RowCount = XlLog.Range("A1048576").End(xlUp).Row
If RowCount > 0 Then
Dim iTotalRows As Long
iTotalRows = XlLog.Rows.Count 'Get total rows in the table'
Dim txt As Variant
Dim iRows As Long
End If
Dim i As Integer
'Insert comment into Word document'
Set wApp = CreateObject("Word.Application")
wApp.Visible = True
If Err Then
Set wApp = CreateObject("Word.Application")
End If
Set objSelection = ActiveDocument
For iRows = 3 To iTotalRows
txt = XlLog.Cells(iRows, 8).Text 'Grabs appropriate comment text'
objSelection.Activate
objSelection.SelectAllEditableRanges
strpgSearch = XlLog.Cells(iRows, 2) 'Grabs appropriate Page number'
strlinSearch = XlLog.Cells(iRows, 3) 'Grabs appropriate Line number'
objSelection.ActiveWindow.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext,
Name:=strpgSearch
objSelection.ActiveWindow.Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative,
Count:=strlinSearch
Set myRange = ActiveWindow.Selection.Range
ActiveDocument.Comments.Add Range:=myRange, Text:=txt
Next iRows
Set xlApp = Nothing
Set SaveDoc = Nothing
Set XlLog = Nothing
Set objSelection = Nothing
Set myRange = Nothing
Set wApp = Nothing
SaveDoc.Close
End Sub
I am trying to open a excel file, take the ranges as picture and create a ppt our of it. I am not sure what is going wrong in the code below. Can someone help please? The code works well for all other slides coming from other excel file. The moment I opena excel file and switch , it is throwing "subscript out of range error"
Sub GlobalBankPPT()
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide
Dim ppShape As PowerPoint.Shape
Dim ppPic As Variant
Dim j As Integer
Dim wkb As Workbook
Dim sh As Worksheet
Dim WS_Count As Integer, i As Integer
Dim mypp As New ExcelToPPt.cPPt
mypp.InitFromTemplate MyTemplateppt:=mytemp, MyOutputppt:=""
Set ppApp = GetObject(, "PowerPoint.Application")
ppApp.Visible = msoTrue
Set ppPres = ppApp.ActivePresentation
Set wkb = Workbooks.Open(Filename:=ThisWorkbook.Worksheets("Index").Range ("FilePath"))
wkb.Activate
WS_Count = wkb.Worksheets.Count
For i = 1 To WS_Count
If Worksheets(i).Name = "Industry" Then
wkb.Activate
Set sh = ActiveSheet
Exit For
End If
Next I
'--------------------------------------------------------------------Slide7
Range(Sheet15.Range("A150"), Sheet15.Range("Q191")).Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ppPres.Slides(7).Select
Set ppPic = ppPres.Slides(7).Shapes.Paste
ppPic.Select
ppPic.Top = 70.24
ppPic.Width = 10.5 * 100
ppPic.Height = ppPic.Width / 3.4
ppPic.Left = 50
end sub
I've cobbled together a VBA script (I'm no expert, but thanks to the kind folks around here, I've been able to get something together and mostly working) to copy from multiple excel sheets into a powerpoint file (used a template, as you will see from the code.
Sub ATestPPTReport()
Dim PPApp As PowerPoint.Application
Dim PPSlide As PowerPoint.Slide
Dim PPPres As PowerPoint.Presentation
Set PPApp = CreateObject("Powerpoint.Application")
Dim SlideNum As Integer
Dim PPShape As PowerPoint.Shape
Set XLApp = GetObject(, "Excel.Application")
''define input Powerpoint template
Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String
''# Change "strPresPath" with full path of the Powerpoint template
strPresPath = "C:\template.ppt"
''# Change "strNewPresPath" to where you want to save the new Presentation to be created
strNewPresPath = "C:\macro_output-" & Format(Date, "dd-mmm-yyyy") & ".ppt"
Set PPPres = PPApp.Presentations.Open(strPresPath)
PPPres.Application.Activate
PPApp.Visible = True
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''define destination slide
SlideNum = 1
PPPres.Slides(SlideNum).Select
Set PPShape = PPPres.Slides(SlideNum).Shapes("slide1box")
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
''define source sheet
Sheets("Info1").Activate
'copy/paste from
XLApp.Range("Info1Block").Copy
PPSlide.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoFalse
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''define destination slide
SlideNum = 2
PPPres.Slides(SlideNum).Select
' Set PPShape = PPPres.Slides(SlideNum).Shapes("slide2box")
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
''define source sheet
Sheets("Info2").Activate
'copy/paste from
XLApp.Range("Info2Block").Copy
PPSlide.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoFalse
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Close presentation
PPPres.SaveAs strNewPresPath
'PPPres.Close
'Quit PowerPoint
'PPApp.Quit
' MsgBox "Presentation Created", vbOKOnly + vbInformation
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub
My problem is: how do I resize/reposition the object once it's been pasted?
The function "PasteSpecial" returns a shape object, which you can use to resize or reposition.
For example:
Dim ppShape as PowerPoint.Shape
set ppShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoFalse)
Then you can use this shape object to resize it. For example:
ppShape.Height = xyz
ppShape.Top = abc
etc etc.
Hope this helps.
Vikas B
This has been working for me:
Set shp = myPresentation.Slides(x).Shapes.PasteSpecial(DataType:=2)
shp.Left = topLeft + 1
shp.Top = midTop + 1
shp.Width = midLeft - topLeft - 1
Note the variables are set locally to place the image where I want it in relation to the slide. You can easily replace with integers.
It also works for DataType:=10 items as well