I created a UserForm, with the help of many, within PowerPoint to assist with consistent embedded chart data entries. From what I have learned I will never do this again because addtional code that is needed to traverse through the PowerPoint to get to the correct location for the desired updates. No matter, I would like to finish the final objective of getting data from the UserForm into the first empty row. I have code but there is an error that is preventing the data to unload. The code I have is below. Any help in identifying the glitch is greatly appreciated.
Private Sub CPDataAdd_Click()
Dim sld As Slide
Dim shp As shape
Dim chrt As Chart
Dim xlWB As Object
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoChart Then
If shp.Name = "DVchart" Then
Set xlWB = shp.Chart.ChartData.Workbook
Exit For
End If
End If
Next
If Not xlWB Is Nothing Then Exit For
Next
Set shp = sld.Shapes("DVchart")
Set xlWB = shp.Chart.ChartData.Workbook
Dim LastRow As Long
With xlWB.Sheets(1)
LastRow = .Range("AI" & Rows.Count).End(xlup).Row + 1
.Range("AI" & LastRow).Value = CPDate.Text
.Range("BI" & LastRow).Value = CPCompleteN.Text
.Range("CI" & LastRow).Value = CPPassN.Text
.Range("DI" & LastRow).Value = CPFailN.Text
.Range("EI" & LastRow).Value = CPNotN.Text
End With
End Sub
Related
So this code will run a Find and Replace on PowerPoint charts. the goal is to replace the x-axis labels. The issue I'm having is that I get this popping up: We couldn't find anything to replace. Click options for more ways to search."
It pops up every time the chart doesn't have the word I'm looking for. So I added rngFound. I want to be able to say "If word is Found then Replace" instead of having my Replace just do everything at once.
So I went and added Set rngFound = Worksheets(1).objRange.Find(fndList). But it's not working. I suspect rngFound isn't actually doing anything for me, and would like any sort of help with this issue. Thank you in advance!
Option Explicit
Private Sub findAndReplaceChrt()
'Timer start
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
Dim pptPres As Object
Dim sld As Slide
Dim shpe As Shape
Dim c As Chart
Dim sht As Object
Dim fndList As Variant
Dim rplcList As Variant
Dim listArray As Long
Dim rngFound As Variant
fndList = Array("Red", "Purple")
rplcList = Array("red", "blue")
'Make pptPres the ppt active
Set pptPres = PowerPoint.ActivePresentation
'Loop through each sld and check for chart title, grab avgScore values and create pptTable to paste into ppt chart
For Each sld In pptPres.Slides
'searches through shapes in the slide
For Each shpe In sld.Shapes
'Checks if shape is a Charts and has a Chart Title
If Not shpe.HasChart Then GoTo nxtShpe
Set c = shpe.Chart
If Not c.ChartType = xlPie Then
ActiveWindow.ViewType = ppViewNormal
c.ChartData.Activate
'Loop through each item in Array lists
For listArray = LBound(fndList) To UBound(fndList)
Set rngFound = Worksheets(1).objRange.Find(fndList)
If Not rngFound Is Nothing Then
Worksheets(1).Cells.Replace What:=fndList(listArray), Replacement:=rplcList(listArray), _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
End If
Next listArray
c.ChartData.Workbook.Close
End If
nxtShpe:
Next shpe
Next sld
'End Timer
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
Im looking for a way to copy the text of the first element of a powerpoint slide into an excel file. I got the following code that prints out the text of the first box:
Sub getText
Dim sld As Slide
Set sld = Application.ActiveWindow.View.Slide
For Each sld In ActivePresentation.Slides
With sld.Shapes(1)
myInput = .TextFrame.TextRange.Text
MsgBox (myInput)
End With
Next
End sub
Now the next step I want to take is to add the data to an excel file. Therefore I try to do the following:
Sub getText()
Dim xlApp As Object
Dim xlWorkBook As Object
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWorkBook = xlApp.Workbooks.Open("~\PROJECTEN\Lopend\office_VA\macroStore.xlsx", True, False)
xlWorkBook.sheets(1).Range("A2").Select
Dim sld As Slide
Set sld = Application.ActiveWindow.View.Slide
For Each sld In ActivePresentation.Slides
With sld.Shapes(1)
myInput = .TextFrame.TextRange.Text
ActiveCell.Text = myInput
End With
Next
End Sub
However when I try it now it get the error: "Object required". Any thoughts on how I should change my code?
Your problem is that you're referencing ActiveCell.Text but VBA has no clue what that is. Also, you haven't declared your myInput variable.
Try this macro, where instead of selecting the cell I'm just assigning the text value to it. Also, if you're writing more than one value your code will keep writing over the same cell. In the code below I've added a couple of lines that will write your text down column A.
Sub getText()
Dim xlApp As Object
Dim xlWorkBook As Object
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWorkBook = xlApp.Workbooks.Open("~\PROJECTEN\Lopend\office_VA\macroStore.xlsx", True, False)
Dim xlWorkSheet As Object ' Create a worksheet object
xlWorkSheet = xlWorkBook.sheets(1) ' Set the sheet you activate to that object
Dim iRow As Long ' Create a variable to store row number
iRow = 1 'Set the first row that you want to start writing data on
Dim sld As Slide
Dim myInput As String
Set sld = Application.ActiveWindow.View.Slide
For Each sld In ActivePresentation.Slides
With sld.Shapes(1)
myInput = .TextFrame.TextRange.Text
xlWorkSheet.Cells(iRow, "A") = myInput 'Using .Cells() you can specify the (row, column) location
iRow = iRow + 1 'increment by one for next line of text
End With
Next
End Sub
I'm trying to write a batch find and replace code for Power Point slides in VBA but I'm getting the following error: Compile Error Method or data member not found.
The debugger is highlighting Shapes in PP.Shapes on line 13.
I do not have much experience with VBA. I gathered ideas from:
* Getting Started with VBA in PowerPoint 2010 (Office Dev Center)
* Power Point VBA-Find & Replace (YouTube)
* "Simple Macro to import slides from a file" # (VBA Express Forum)
Sub BatchFindReplace()
Dim shp As Shape
Dim strFileName As String
Dim strFolderName As String
Dim PP As Presentation
'Directory
strFolderName = "C:\Users\Emma\Desktop\temp1"
strFileName = Dir(strFolderName & "\*.ppt*")
Do While Len(strFileName) > 0
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
'Find and Replace Code
For Each shp In PP.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "W", "kkk")
End If
End If
Next
PP.Close
strFileName = Dir
Loop
End Sub
The property .Shapes is not a member of Presentation but of Slide
'~~> Open the relevant powerpoint file
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
'~~> Change this to the relevant slide which has the shape
Set PPSlide = PP.Slides(1)
For Each shp In PPSlide.Shapes
Debug.Print shp.Name
Next shp
If you want to work with all shapes in all slides then you will have to loop through slides.
Dim sld As Slide
'~~> Open the relevant powerpoint file
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
For Each sld In PP.Slides
For Each shp In sld.Shapes
Debug.Print shp.Name
Next shp
Next
When I call each module separately everything works fine... but when I call them from the MAIN module the text does not shrink on overflow on the saved slides. Can you please help to find a way to fix this
Sub MAIN()
Call Module1.CreateSlides
Call Module2.SaveSlides
End Sub
[Module1]
Sub CreateSlides()
'Open the Excel workbook. Change the filename here.
Dim OWB As New Excel.Workbook
Set OWB = Excel.Application.Workbooks.Open("C:\B\Books\TXT.xlsx")
'Grab the first Worksheet in the Workbook
Dim WS As Excel.Worksheet
Set WS = OWB.Worksheets(1)
'Loop through each used row in Column A
For i = 1 To WS.Range("A65536").End(xlUp).Row
'Copy the first slide and paste at the end of the presentation
ActivePresentation.Slides(1).Copy
ActivePresentation.Slides.Paste (ActivePresentation.Slides.Count + 1)
'Change the text of the first text box on the slide.
ActivePresentation.Slides(ActivePresentation.Slides.Count).Shapes(1).TextFrame.TextRange.Text = WS.Cells(i, 1).Value
ActivePresentation.Slides(ActivePresentation.Slides.Count).Shapes(2).TextFrame.TextRange.Text = WS.Cells(i, 2).Value
ActivePresentation.Slides(ActivePresentation.Slides.Count).Shapes(3).TextFrame.TextRange.Text = WS.Cells(i, 3).Value
Next
'Close Excel
ActiveWorkbook.Close
'Delete presentation
ActivePresentation.Slides(1).Delete
End Sub
[Module2]
Sub SaveSlides ()
'Save slides as png
Dim sImagePath As String
Dim sImageName As String
Dim oSlide As Slide '* Slide Object
On Error GoTo Err_ImageSave
sImagePath = "C:\"
For Each oSlide In ActivePresentation.Slides
sImageName = oSlide.SlideNumber & ".png"
oSlide.Export sImagePath & sImageName, "PNG"
Next oSlide
Err_ImageSave:
If Err <> 0 Then
MsgBox Err.Description
End If
'Delete all slides
Dim Pre As Presentation
Set Pre = ActivePresentation
Dim x As Long
For x = Pre.Slides.Count To 1 Step -1
Pre.Slides(x).Delete
Next x
'Add New slide
Set pptLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(1)
Set Sld = ActivePresentation.Slides.AddSlide(1, pptLayout)
Sld.Design = ActivePresentation.Designs(1)
End Sub
You mentioned "the text does not shrink on overflow on the saved slides". What text are you referring to? There are no lines that are setting the following property in your code so any on-slide objects should be following the properties of those objects in your Slide Master (and associated Custom Layouts).
Sld.Shapes(x).TextFrame2.AutoSize = msoAutoSizeShapeToFitText
Try using the above line to explicitly set the fit option as required. Modified sub:
Option Explicit
Sub CreateSlides()
'Open the Excel workbook. Change the filename here.
Dim OWB As New Excel.Workbook
Set OWB = Excel.Application.Workbooks.Open("C:\B\Books\TXT.xlsx")
Dim i As Long
'Grab the first Worksheet in the Workbook
Dim WS As Excel.Worksheet
Set WS = OWB.Worksheets(1)
'Loop through each used row in Column A
For i = 1 To WS.Range("A65536").End(xlUp).Row
With ActivePresentation
'Copy the first slide and paste at the end of the presentation
.Slides(1).Copy
.Slides.Paste (.Slides.Count + 1)
'Change the text of the first text box on the slide.
With .Slides(.Slides.Count).Shapes(1).TextFrame2
.AutoSize = msoAutoSizeShapeToFitText
.WordWrap = msoTrue
.TextRange.Text = WS.Cells(i, 1).Value
End With
With .Slides(.Slides.Count).Shapes(2).TextFrame2
.AutoSize = msoAutoSizeShapeToFitText
.WordWrap = msoTrue
.TextRange.Text = WS.Cells(i, 2).Value
End With
With .Slides(.Slides.Count).Shapes(3).TextFrame2
.AutoSize = msoAutoSizeShapeToFitText
.WordWrap = msoTrue
.TextRange.Text = WS.Cells(i, 3).Value
End With
End With
Next
'Close Excel
ActiveWorkbook.Close
'Delete presentation
ActivePresentation.Slides(1).Delete
End Sub
This appears to be a bug in PowerPoint. I've run into the same problem myself.
If you can run the whole main batch of code, then separately run another small module to "tidy up" the text, you can fix this.
Somewhere in the main code, tag each shape that holds text (or perhaps just the ones set to shrink on overflow). For example, if you had a reference to the shape in oSh:
oSh.Tags.Add "H", cStr(oSh.Height)
oSh.Tags.Add "W", cStr(oSh.Width)
Now the shape is tagged with the size it SHOULD be. When your main code pours text into it, the size will reset (incorrectly... there's the bug).
So later, separately, you run code that
' Looks at each shape on each slide and
' if it's tagged, reset the size to the
' size indicated by the tags:
If Len(oSh.Tags("H")) > 0 Then
oSh.Height = cSng(oSh.Tags("H")
oSh.Width = cSng(oSh.Tags("W")
End if
Fixup module to be applied separately
Sub FixUp()
Dim Obj1 As Object
Set Obj1 = CreateObject("powerpoint.application")
Obj1.Presentations.Open FileName:="C:\B\name.pptm"
Dim pptSlide As Slide
Dim pptShape as Shape
'Set pptSlide = ActivePresentation.Slides(1)
For Each pptSlide in ActivePresentation.Slides
'With pptSlide.Shapes(1)
For Each pptShape in pptSlide.Shapes
With pptShape
If .TextFrame2.TextRange.Characters.Count > 1 Then
.TextFrame2.AutoSize = msoAutoSizeTextToFitShape
End If
End With ' pptShape
Next ' pptShape
End With
Next ' Slide
End Sub
Below is a code that allows you to select a shape, then it populates cells in Excel by giving shape name, content, slide number, and commentary (for your personal notes). BUT instead of selecting one shape at a time, I would like to select ALL or more than one shape at a time to populate back to the Excel sheet.
Can anyone help?
Here is the code:
Dim ppapp As PowerPoint.Application
Dim pppres As PowerPoint.Presentation
Sub getshapedata()
On Error GoTo line1
Set ppapp = GetObject(, "Powerpoint.application")
Set pppres = ppapp.ActivePresentation
Dim shapeslide
Dim shapename
Dim shapetext
Dim nextrow
shapeslide = ppapp.ActiveWindow.View.Slide.SlideIndex
shapename = ppapp.ActiveWindow.Selection.ShapeRange(1).Name
shapetext = pppres.Slides(shapeslide).Shapes(shapename).TextEffect.Text
friendlyname = InputBox("Insert Friendly Name for " & shapetext, "Friendly Name", "")
nextrow = Sheet1.Range("a" & Rows.Count).End(xlUp).Row + 1
Sheet1.Range("a" & nextrow) = shapeslide
Sheet1.Range("b" & nextrow) = shapename
Sheet1.Range("c" & nextrow) = shapetext
Sheet1.Range("d" & nextrow) = friendlyname
Exit Sub
line1:
MsgBox "No item selected"
End Sub
Sub writedata()
Dim c As Object
Dim shapeslide
Dim shapename
Dim shapetext
Set ppapp = GetObject(, "Powerpoint.application")
Set pppres = ppapp.ActivePresentation
For Each c In Sheet1.Range("a2:a" & Sheet1.Range("a" & Rows.Count).End(xlUp).Row)
shapeslide = Sheet1.Range("a" & c.Row)
shapename = Sheet1.Range("b" & c.Row)
shapetext = Sheet1.Range("c" & c.Row).Text
friendlyname = Sheet1.Range("d" & c.Row)
pppres.Slides(shapeslide).Shapes(shapename).TextEffect.Text = shapetext
Next c
End Sub
Declare a Slide variable and a Shape variable to use as an iterator:
Dim ppSlide as Object 'PowerPoint.Slide
Dim ppShape as Object 'PowerPoint.Shape
Then set it to your slide:
Set ppSlide = ppapp.ActiveWindow.View.Slide
Then, iterate over the shapes collection on that slide:
For each pptShape in ppSlide.Shapes
If ppShape.HasTextFrame Then
'### DO STUFF
End If
Next
In your code, something like below, as amended with the custom function GetPPTSelection, based on the comment:
I don't want ALL the shapes to write back to excel, only the ones I select. How do I go about doing that?
The function GetPPTSelection returns a Collection of shapes (if any are selected) and I think it should handled "Grouped" shapes, as well as multiple selections, and also ignores shapes which don't have a TextFrame (embedded images, etc.)
Sub getshapedata()
Dim ppSlide As Object 'PowerPoint.Slide
Dim ppShape As Object 'PowerPoint.Shape
Dim nextrow As Long
Set ppapp = GetObject(, "Powerpoint.application")
Set pppres = ppapp.ActivePresentation
Set ppSlide = ppapp.ActiveWindow.View.Slide
For each ppShape in GetPPTSelection(ppPres.Windows(1))
friendlyname = InputBox("Insert Friendly Name for " & shapetext, "Friendly Name", "")
With Sheet1
nextrow = .Range("a" & .Rows.Count).End(xlUp).Row + 1
.Range("a" & nextrow) = ppSlide.SlideIndex
.Range("b" & nextrow) = ppShape.Name
.Range("c" & nextrow) = ppShape.TextEffect.Text
.Range("d" & nextrow) = friendlyname
End With
Next
Exit Sub
Function GetPPTSelection(window As Object)
' Returns a Collection of selected shapes, if shapes are selected
' Returns a Nothing, if anything else (slides, text, etc.) selected
Dim coll As New Collection
Dim c As Integer
Dim s As Integer
Dim g As Integer
Dim sel As Object '# PowerPoint.Selection
Const ppSelectionShapes As Long = 2 ' in case of late binding
Set sel = window.Selection
If sel.Type = ppSelectionShapes Then
For s = 1 To sel.ShapeRange.Count
If IsGrouped(sel.ShapeRange(s)) Then
'# handle grouped shapes
For g = 1 To sel.ShapeRange(s).GroupItems.Count
coll.Add sel.ShapeRange(s).GroupItems(g)
Next
Else:
'# ordinary, ungrouped shapes:
coll.Add sel.ShapeRange(s)
End If
Next
End If
'# Get rid of any shapes which don't have a textframe:
For c = coll.Count To 1 Step -1
If Not coll(c).HasTextFrame Then coll.Remove (c)
Next
'# Return the collection to the calling procedure:
Set GetPPTSelection = coll
End Function
Function IsGrouped(shp As Object)
'Returns boolean if shape is groupshapes
Dim ret As Boolean
On Error Resume Next
ret = shp.GroupItems.Count > 1
IsGrouped = ret
End Function
I got rid of the On Error GoTo Line1 because there is no label Line1 in this code, also, I think it's generally better to anticipate and trap errors, rather than using a catchall like that which tends to make debugging real problems that much more difficult. If this code is still raising some errors, let me know which line and I can try to help debug it.
Or, just use On Error Resume Next at your own peril :)