Sub ToPowerPoint()
Dim pApp As PowerPoint.Application
Dim pSilde As PowerPoint.Slide
Dim pPres As PowerPoint.Presentation
'I have declared here pp Objects
Application.EnableEvents = False
Application.ScreenUpdating = False
'Turning off screen updating
Set pApp = New PowerPoint.Application
pApp.Visible = True
'Setting up new pp instance
pApp.Activate
Set pPres = pApp.Presentations.Add
Set pSlide = pPres.Slides.Add(1, ppLayoutBlank)
'Adding up new presentation and slide within pp
pSlide.Select
Dim wb As Excel.Workbook
Dim sh As Excel.Worksheet
Set wb = Workbooks("BC_WTB__DRAFT.xlsb")
'setting up here xl workbooks
'
wb.Activate
Worksheets("BS").Visible = True
Worksheets("BS").Select
Worksheets("BS").Range("G5:H5").Select
Selection.Copy
pSlide.Shapes.PasteSpecial ppPasteRTF
**'copying some cell values here and below**
Worksheets("BS").Range("G12").Select
Selection.Copy
pSlide.Shapes.PasteSpecial ppPasteEnhancedMetafile
pApp.ActiveWindow.Selection.ShapeRange.Top = 193
Worksheets("BS").Range("H12").Select
Selection.Copy
pSlide.Shapes.PasteSpecial ppPasteEnhancedMetafile
pApp.ActiveWindow.Selection.ShapeRange.Top = 193
'I need to align pasted objects in one horizontal line
'without using Top or Left methods
'I need help after copied cells are pasted in pp, to align them in
'some vertical and horizontal line without using top or left method.
End Sub
ExcelHelp.
If you are trying to aling objects in powepoint presentation you can use the native alingment and distribute functions.
Just adding this at the and of your code.
Dim myArray() As Variant, myRange As Object
myArray = Array("img1", "img2", "txt1")
Set myRange = ActivePresentation.Slides(1).Shapes.Range(myArray)
myRange.Distribute msoDistributeHorizontally, msoFalse
myRange.Distribute msoDistributeVertically, msoFalse
myRange.Align msoAlignLefts, msoFalse
You just need to change names of the defaut shapes in the array (names change because we have different languages).
If you need to aling left, or top or right use the last line, or distribute heights / widths
I've the following piece of code which exports excel sheets to powerpoint. In each sheet it takes the range from cells A1 and A2 and copies that range into powerpoint.
Now I want to add two functions, but I have no clue how to do this, so I am hoping anyone can help me with this?
1 - In sheets where only a table is included, the code does exactly what it's supposed to do. However in some sheets I've included a picture or a chart and these are not properly pasted in excel. (only a blank picture is copied in the powerpoint slide). Now I want to make a code that uses my input from cell "C1" to determine whether this slide needs to be pasted as an image or as a normal paste. I've tried to fix this but my code continuously gets an error. Is there any way that I can adjust this code so that I will get it working?
2 - The code now copies all worksheets, but I want it to start at sheet 7 and continue from there till the end. Thus skipping the first 6 worksheets. Does anyone have a clue how I can exclude these sheets in my VBA?
Sub PrintPPT()
'Step 1: Declare variables
Dim pp As Object
Dim PPPres As Object
Dim PPSlide As Object
Dim xlwksht As Worksheet
Dim MyRange As String
'Step 2: Open PowerPoint, add a new presentation and make visible
Set pp = CreateObject("PowerPoint.Application")
Set PPPres = pp.Presentations.Add
pp.Visible = True
'Step 3: Start the loop through each worksheet
For Each xlwksht In ActiveWorkbook.Worksheets
MyRange = xlwksht.Range("A1").Value & ":" & xlwksht.Range("A2").Value
xlwksht.Range(MyRange).Copy
'Step 4: Count slides and add new blank slide as next available slide number
'(the number 12 represents the enumeration for a Blank Slide)
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, 12)
PPSlide.Select
'Step 5: Paste the picture and adjust its position
PPPres.ApplyTemplate ("C:\Users\Template.potx")
Pastetype = xlwksht.Range("C1").Value
' Pastetype will be "PasteSpecial DataType:=2" for images
' Pastetype will be "Paste.Select" for normal
PPSlide.Shapes.pastetype '2 = ppPasteEnhancedMetafile
'pp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pp.ActiveWindow.Selection.ShapeRange.Top = 85
pp.ActiveWindow.Selection.ShapeRange.Left = 7.2
'pp.ActiveWindow.Selection.ShapeRange.Width = 600
'Step 6: Add the title to the slide then move to next worksheet
Next xlwksht
'Step 7: Memory Cleanup
pp.Activate
Set PPSlide = Nothing
Set PPPres = Nothing
Set pp = Nothing
End Sub
Am trying to hide or move a series of shapes in excel.
I have a range of cells that I want to copy as a picture and basically if the shape isn't 'active' i.e. contains text then I don't want the shapes to be visable in this range of cells. Each shape is linked and if the if/vlookup is true the shape will contain text.
The following is not working - have tried modifying .Visable with .Right i.e. to shift the shapes out of range - but it says object does not support this property or method.
Sub Macro3()
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
Dim shp As Shape
Dim tr As TextRange2
Dim grp As Shape
Dim sShape As Shape
Set shp = ws.Shapes("Line Callout 1 2")
Set tr = shp.TextFrame2.TextRange
For Each ws In ThisWorkbook.Worksheets
For Each shp In ws
If shp.Name Like "Line Callout 1" And tr.Characters.Text = "" Then
sShape.Right = 300
Else
sShape.Right = 0
End If
Next shp
Next ws
End Sub
If I specify a named cell I can alter the visability but for over 600 shapes I want to auomate this somehow This works for named shape and named range:
Sub Macro1()
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
With ws.Shapes.Range(Array("Line Callout 1 1"))
.Fill.Visible = Range("x")
.Line.Visible = Range("x")
End With
End Sub
I am interning with a large firm that stores a lot of its source data in the form of PowerPoints. These PowerPpoints serve well when communicating across departments and between suppliers but, as you may guess, lack any robust analysis. Because of this, I have decided to database these Powerpoints into Access.
There is no direct way of doing this, that I know of. Due to strict IT policies, I am limited to VBA as my coding platform. I have spent the last week coding up a macro to solve my problem. Again, since there is no direct conversion of PowerPoint to Access, I have had to solve this problem rather inefficiently as there are a few caveats. I will list my steps and caveats below.
The powerpoint information I want to database is formatted as a table instead of text. I have been unable to find a Macro that converts PPT tables directly to Excel or CSV files. Because of this, I will convert all PPT files (roughly 3000) to PDFs.
From these generated PDF's I can use Adobe to convert them to Excel or CSV files.
Using multiple online resources and a bit of my own experience, I have coded up a VBA script that will automatically format a folder of CSV files into a format that Access will store correctly. See Code 1.
(The "Personal.xlsb!Module1.FormatAccess" is a macro created mostly with "Record Macro." I omitted this code due to its length and redundancy.)
After formatting the CSVs, I will then automate them all to Access.
Following the Access automation, I will need to embed each PPT file to its respective Access entry
Again, this is not an efficient process. Because I am limited to Microsoft only applications, I have chosen this route. I thought about leaving the information as Excel files, but the idea is to make this data accessible and searchable by any department, hence why I chose Access to database them.
Now that I have explained to you where I am coming from and what I am doing, I ask: what recommendations do you have for me? I feel my round-about way is a good solution and practical, but I wonder if there is a better solution.
Code 1
Sub LoopCSVFile()
Dim fso As Object 'Scritping.FileSystemObject
Dim fldr As Object 'Scripting.Folder
Dim file As Object 'Scripting.File
Dim wb As Workbook
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldr = fso.GetFolder("C:\Users\HMM105289\Documents\Powerpoint Parsing\Test Folder\Test Save Folder")
For Each file In fldr.Files
Set wb = Workbooks.Open(file.Path)
Application.Run "Personal.xlsb!Module1.FormatAccess"
wb.Close SaveChanges = True
Next
Set file = Nothing
Set fldr = Nothing
Set fso = Nothing
End Sub
Edit 1
Having played around with some of Tim's suggestions, I have come up with this code to run a check on each PPT slide. The idea is to have it run his "ExtractTable" macro inside. As it stands, I am unable to get it to execute.
Sub PPTableXtraction()
Dim oSlide As Slide
Dim oSlides As Slides
Dim oPPT As Object: Set oPPT = ActivePresentation
Dim oShapes As Shape
Dim oTable As Object
For Each oSlide In oPPT.Slides
For Each oShapes In oSlide.Shapes
If oShapes.HasTable Then
Application.Run "VBAProject.xlsb!Module3.ExtractTableContent"
End If
Next
Next
End Sub
Edit 2
I was able to build on Tim's code to create a code that loops each PowerPoint file and extracts the information into Excel. The code doesn't break into the debugger but for whatever reason it is not performing any functions. Would anyone have any idea why?
Sub Tester()
Dim ppts As PowerPoint.Application
Dim FolderPath As String
Dim FileName As String
FolderPath = "FolderPath"
FileName = Dir(FolderPath & "*.ppt*")
Do While FileName <> ""
Set ppts = New PowerPoint.Application
ppts.Visible = True
ppts.Presentations.Open FileName:=FolderPath & FileName
A = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 5
B = "B" & A
X = "A" & A
Range(X).Value = "New"
Dim ppt As Object, tbl As Object
Dim slide As Object, pres As Object, shp
Dim rngDest As Range
Set ppt = GetObject(, "Powerpoint.Application")
Set pres = ppt.ActivePresentation
Set rngDest = Sheets("Data").Range(B) '
For Each slide In pres.Slides
For Each shp In slide.Shapes
If shp.HasTable Then
ExtractTableContent shp.Table, rngDest
Set rngDest = rngDest.Offset(shp.Table.Rows.Count + 3, 0)
End If
Next
Next
ppts.ActivePresentation.Close
FileName = Dir
Loop
End Sub
Sub ExtractTableContent(oTable As Object, rng As Range)
Dim r, c, offR As Long, offC As Long
For Each r In oTable.Rows '<< Loop over each row in the PPT table
offC = 0 '<< reset the column offset
For Each c In r.Cells '<< Loop over each cell in the row
'Copy the cell's text content to Excel, using the offsets
' offR and offC to select where it gets placed relative
' to the starting point (rng)
rng.Offset(offR, offC).Value = c.Shape.TextFrame.TextRange.Text
offC = offC + 1 '<< increment the column offset
Next c
offR = offR + 1 '<< increment the row offset
Next r
End Sub
Sub N()
Range("A3").Value = "New"
End Sub
Here's an example of extracting a table from PPT to Excel.
Looping over the slides and tables (modified from your posted code)
Sub Tester()
Dim ppt As Object, tbl As Object
Dim slide As Object, pres As Object, shp
Dim rngDest As Range
Set ppt = GetObject(, "Powerpoint.Application")
Set pres = ppt.ActivePresentation
Set rngDest = Sheets("Data").Range("a1") '<< where to start placing ppt data
For Each slide In pres.Slides
For Each shp In slide.Shapes
If shp.HasTable Then
ExtractTableContent shp.Table, rngDest
Set rngDest = rngDest.Offset(shp.Table.Rows.Count + 3, 0)
End If
Next
Next
End Sub
The sub to extract each table's data:
Sub ExtractTableContent(oTable As Object, rng As Range)
Dim r, c, offR As Long, offC As Long
For Each r In oTable.Rows '<< Loop over each row in the PPT table
offC = 0 '<< reset the column offset
For Each c In r.Cells '<< Loop over each cell in the row
'Copy the cell's text content to Excel, using the offsets
' offR and offC to select where it gets placed relative
' to the starting point (rng)
rng.Offset(offR, offC).Value = c.Shape.TextFrame.TextRange.Text
offC = offC + 1 '<< increment the column offset
Next c
offR = offR + 1 '<< increment the row offset
Next r
End Sub
In case anyone skims this and wants the solution used
It is out of the box ready, with the exception of setting your file path.
Sub Tester()
Dim rng As Range
Set rng = Range("A1") 'This code is necessary to prevent a constant loop of the formatting for each extraction. It adds a "1" into "A1"
rng.Value = 1
Dim ppts As PowerPoint.Application
Dim FolderPath As String
Dim FileName As String
FolderPath = "FolderPath" 'Define your Folder Path
FileName = Dir(FolderPath & "*.ppt*") 'Locate .PPT files
Do While FileName <> ""
Set ppts = New PowerPoint.Application 'Left this in after finding another fix. Opens new instance each time
ppts.Visible = True
ppts.Presentations.Open FileName:=FolderPath & FileName
'The code below sets 3 variables to help in formatting Tim's extraction code.
'It searches for the last cell entry and then adds 5 rows before copying more information.
A = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 5
B = "B" & A
X = "A" & A
Range(X).Value = "New"
'Beginning of Tim's code
Dim ppt As Object, tbl As Object
Dim slide As Object, pres As Object, shp
Dim rngDest As Range
Set ppt = GetObject(, "Powerpoint.Application")
Set pres = ppt.ActivePresentation
Set rngDest = Sheets("Data").Range(B) 'Moved it over one column for formatting
For Each slide In pres.Slides
For Each shp In slide.Shapes
If shp.HasTable Then
ExtractTableContent shp.Table, rngDest
Set rngDest = rngDest.Offset(shp.Table.Rows.Count + 3, 0)
End If
Next
Next
ppts.ActivePresentation.Close 'Close PPT and loop for next one
FileName = Dir
Loop
End Sub
'More of Tim's code
Sub ExtractTableContent(oTable As Object, rng As Range)
Dim r, c, offR As Long, offC As Long
For Each r In oTable.Rows '<< Loop over each row in the PPT table
offC = 0 '<< reset the column offset
For Each c In r.Cells '<< Loop over each cell in the row
'Copy the cell's text content to Excel, using the offsets
' offR and offC to select where it gets placed relative
' to the starting point (rng)
rng.Offset(offR, offC).Value = c.Shape.TextFrame.TextRange.Text
offC = offC + 1 '<< increment the column offset
Next c
offR = offR + 1 '<< increment the row offset
Next r
End Sub
Sub N()
Range("A3").Value = "New" 'Simply adds "New" next to each new file opened. Helps for deliniation between files
End Sub
I'm using MS Excel for Mac V15.32 on macOS Sierra V10.12.3.
I'm trying to apply a practice example of VBA code to move data from Excel to PPT. It's breaking about halfway through on the following line:
PPSlide.Shapes.Paste.Select
The error message is "Run-time error '424': Object required".
I tried using a snippet of code from an answer to a similar question (Copy Charts from Excel to PPT using VBA Macro), but that just crashed both applications. That code is commented out in Step 5. Code below and file here: https://www.dropbox.com/s/7maeqlkiciyxhwy/CopyDataToPPT.xlsm?dl=0.
Thanks for your help,
David
--
`' http://www.dummies.com/software/microsoft-office/excel/sending-
excel-data-to-a-powerpoint-presentation/
Sub CopyRangeToPresentation()
'Step 1: Declare your variables
Dim PP As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim SlideTitle As String
'Step 2: Open PowerPoint and create new presentation
Set PP = New PowerPoint.Application
Set PPPres = PP.Presentations.Add
PP.Visible = True
'Step 3: Add new slide as slide 1 and set focus to it
Set PPSlide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPSlide.Select
'Step 4: Copy the range as a picture
Sheets("Slide Data").Range("A1:J28").CopyPicture _
Appearance:=xlScreen, Format:=xlPicture
'Step 5: Paste the picture and adjust its position
PPSlide.Shapes.Paste.Select
'PPPres.Slides(PPPres.Slides.Count).Shapes.Paste
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
'Step 6: Add the title to the slide
SlideTitle = "My First PowerPoint Slide"
PPSlide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
'Step 7: Memory Cleanup
PP.Activate
Set PPSlide = Nothing
Set PPPres = Nothing
Set PP = Nothing
End Sub
--