I need a macro for deleting all datalabels in a linechart except the last two.
I've managed to delete one column of labels, any help on how i can delete the rest.
Here is the code im using currently:
Option Explicit
Sub Format_linechart()
Dim sld As Slide
Dim shp As Shape
Dim chart As chart
Dim sr As Series
Dim i As Long
Dim Cnt As Integer
Set sld = Application.ActiveWindow.View.Slide
For Each shp In sld.Shapes
If shp.HasChart Then
Set chart = shp.chart
For i = 1 To chart.SeriesCollection.Count
Set sr = chart.SeriesCollection(i)
sr.HasDataLabels = True
sr.Points(sr.DataLabels.Count - 2).DataLabel.Delete
Next i
End If
Next shp
End Sub
I've also tried adding lines for each set of datalabels but i then get an error if there are to few datapoints in the chart.
Option Explicit
Sub Format_linechart()
Dim sld As Slide
Dim shp As Shape
Dim chart As chart
Dim sr As Series
Dim i As Long
Dim Cnt As Integer
Set sld = Application.ActiveWindow.View.Slide
For Each shp In sld.Shapes
If shp.HasChart Then
Set chart = shp.chart
For i = 1 To chart.SeriesCollection.Count
Set sr = chart.SeriesCollection(i)
sr.HasDataLabels = True
sr.Points(sr.DataLabels.Count - 2).DataLabel.Delete
sr.Points(sr.DataLabels.Count - 3).DataLabel.Delete
sr.Points(sr.DataLabels.Count - 4).DataLabel.Delete
sr.Points(sr.DataLabels.Count - 5).DataLabel.Delete
sr.Points(sr.DataLabels.Count - 6).DataLabel.Delete
Next i
End If
Next shp
End Sub
For each each series, you can loop through each point and delete the data label for the desired points . . .
Option Explicit
Sub Format_linechart()
Dim sld As Slide
Dim shp As Shape
Dim chart As chart
Dim sr As Series
Dim i As Long
Dim j As Long
Dim Cnt As Integer
Set sld = Application.ActiveWindow.View.Slide
For Each shp In sld.Shapes
If shp.HasChart Then
Set chart = shp.chart
For i = 1 To chart.SeriesCollection.Count
Set sr = chart.SeriesCollection(i)
sr.HasDataLabels = True
For j = 1 To sr.Points.Count - 2
sr.Points(j).DataLabel.Delete
Next j
Next i
End If
Next shp
End Sub
Related
I am trying to copy all true or checked boxes on all slides and paste them onto one slide within my presentation. I can't seem to figure it out. Below is the code that I am using. Any help is appreciated.
`Sub ckbxCopy()
Dim shp As Shape
Dim sld As Slide
Dim i As Integer
On Error Resume Next
For Each sld In ActivePresentation.Slides
For i = 1 To 4
shp = ActivePresentation.Slides("CheckBox" & CStr(i))
If Err.Number = 0 Then ' shape exists
If shp.OLEFormat.Object.Value = True Then
shp.Copy
ActivePresentation.Slides(3).Shapes.Paste
End If
End If
Next i
Next sld
End Sub`
This works for me:
Sub ckbxCopy()
Dim shp As Shape, pres As Presentation
Dim sld As Slide, sldDest As Slide
Dim i As Integer, t As Long
Set pres = ActivePresentation
Set sldDest = pres.Slides(3) 'where shapes are to be pasted
sldDest.Shapes.Range.Delete 'remove existing shapes
t = 20
For Each sld In pres.Slides
If sld.SlideIndex <> sldDest.SlideIndex Then
For i = 1 To 4
Set shp = Nothing
Set shp = SlideShape(sld, "CheckBox" & CStr(i))
If Not shp Is Nothing Then
If shp.OLEFormat.Object.Value = True Then
shp.Copy
pres.Slides(3).Shapes.Paste.Top = t 'paste and position
t = t + 20
End If
End If
Next i
End If
Next sld
End Sub
'Return a named shape from a slide (or Nothing if the shape doesn't exist)
Function SlideShape(sld As Slide, shapeName As String) As Shape
On Error Resume Next
Set SlideShape = sld.Shapes(shapeName)
End Function
I want to select some characters in textrange. It works when I use "With activepresentation.slides(2).shapes(2)".
The codes:
dim Txtrng as textrange
dim Words_Instr as integer
dim aa as string
With ActivePresentation.Slides(2).Shapes(2)
Set Txtrng = .TextFrame.textRange
aa = "AAAA"
Words_Instr = InStr(Txtrng, aa)
If Words_Instr > 0 Then
Txtrng.Characters(Words_Instr, Len(aa)).Select
end if
end with
It doesn't work when I use "pres.". I want to do the same thing in every shape of every slide.
The Codes:
dim pres as presentation
dim sli as slide
dim shp as shape
dim Txtrng as textRange
dim Words_Instr as integer
dim aa as string
set pres=Presentations.Open(filename:=f1)
aa = "AAAA"
For Each sLi In pRes.Slides
for each sHp in sLi.shapes
If sHp.HasTextFrame = msoTrue Then
Set Txtrng = sHp.TextFrame.textRange
Words_Instr = InStr(Txtrng, aa)
If Words_Instr > 0 Then
Txtrng.Characters(Words_Instr, Len(aa)).Select
end if
end if
next
next
It always showed error in “txtrng.characters(...).select”
I will be grateful for any help.
If you only refer to current presentation instead of open another ppt, then the following code will do, I only change set pre part only, copy and paste this code into your existing ppt and run it, it will select the text on the shape:
Sub test()
Dim pres As Presentation
Dim sli As Slide
Dim shp As Shape
Dim Txtrng As TextRange
Dim Words_Instr As Integer
Dim aa As String
Set pres = ActivePresentation
aa = "AAAA"
For Each sli In pres.Slides
For Each shp In sli.Shapes
If shp.HasTextFrame = msoTrue Then
Set Txtrng = shp.TextFrame.TextRange
Words_Instr = InStr(Txtrng, aa)
If Words_Instr > 0 Then
Txtrng.Characters(Words_Instr, Len(aa)).Select
End If
End If
Next
Next
End Sub
I am trying to create a macro which copies the text from all the tables in a slide. I can select the tables but failed to copy text entries from tables. I need to paste the copied text to a excel spreadsheet.
Here is the script:
Option Explicit
Sub GetTableNames()
Dim pptpres As Presentation
Set pptpres = ActivePresentation
Dim pptSlide As Slide
Set pptSlide = Application.ActiveWindow.View.Slide
Dim pptShapes As Shape
Dim pptTable As Table
For Each pptSlide In pptpres.Slides
For Each pptShapes In pptSlide.Shapes
If pptShapes.HasTable Then
Set pptTable = pptShapes.Table
pptShapes.Select msoFalse
pptShapes.TextFrame.TextRange.Copy
End If
Next
Next
End Sub
enter image description here
enter image description here
Try this code:
Sub GetTableNames()
Dim pptpres As Presentation
Set pptpres = ActivePresentation
Dim pptSlide As Slide
Set pptSlide = Application.ActiveWindow.View.Slide
Dim pptShapes As Shape, pptTable As Table
Dim XL As Object, WS As Object
Dim arr As Variant, nextTablePlace As Integer, cnt As Integer
Set XL = CreateObject("Excel.Application")
With XL.Workbooks.Add
Set WS = .Worksheets(1)
End With
nextTablePlace = 1 ' to output first table content into Worksheet
For Each pptSlide In pptpres.Slides
For Each pptShapes In pptSlide.Shapes
If pptShapes.HasTable Then
cnt = cnt + 1
Set pptTable = pptShapes.Table
WS.Cells(nextTablePlace, 1) = "Table #: " & cnt ' caption for each table
nextTablePlace = nextTablePlace + 1
ReDim arr(1 To pptTable.Rows.Count, 1 To pptTable.Columns.Count) ' resize array to table dimensions
For rr = 1 To pptTable.Rows.Count
For cc = 1 To pptTable.Columns.Count
arr(rr, cc) = pptTable.Cell(rr, cc).Shape.TextFrame.TextRange.Text 'get text from each cell into array
Next
Next
' flush the arr to Worksheet
WS.Cells(nextTablePlace, 1).Resize(pptTable.Rows.Count, pptTable.Columns.Count) = arr
' to next place with gap
nextTablePlace = nextTablePlace + pptTable.Rows.Count + 2
End If
Next
Next
XL.Visible = True
End Sub
I have a presentation with many shapes and want to name each of them as "MyPicture#", where # is a number. For example shape 65 would be named MyPicture65. Can VBA do this? How then?
Sub test()
Dim sld As Slide
Dim shp As Shape
Dim lctr As Long
For Each sld In ActiveWindow.Presentation.Slides
For Each shp In sld.Shapes
lctr = lctr + 1
shp.Name = "MyPicture" & lctr
Next
Next
End Sub
I have PPTs that are being generated via software that I have no control over. Upon generation, the software puts all text into TextBoxes instead of my Placeholders.
I created a script to move the text from the TextBoxes into the placeholders and this works great; however, I am unable to maintain the links and the lists are always showing as Bulleted despite some being numbers. Basically, if there is a link in the textbox, it should still be a link in the Placeholder. FYI, this script also changes shape 3 on each slide into the Title Placeholder
How can I preserve the formatting when I am moving the text over? I attempted to use pastespecial, but that still was only moving the text into the format of the placeholder.
Sub TextBoxFix()
Dim osld As Slide, oshp As Shape, oTxR As TextRange, SlideIndex As Long, myCount As Integer, numShapesOnSlide As Integer
Dim tempBulletFormat As PowerPoint.PpBulletType
For Each osld In ActivePresentation.Slides
myCount = 1
With ActivePresentation
'For Each oshp In osld.Shapes
osld.CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(2)
For i = osld.Shapes.Count To 1 Step -1
Set oshp = osld.Shapes(i)
If i = 3 Then
osld.Shapes.Placeholders.Item(1).TextFrame.TextRange = oshp.TextFrame.TextRange.Characters
osld.Shapes.Placeholders.Item(1).Visible = msoTrue
oshp.Delete
ElseIf i > 3 And oshp.Type = msoTextBox Then
oshp.TextFrame.TextRange.Copy
osld.Shapes.Placeholders.Item(2).TextFrame.TextRange.InsertBefore(oshp.TextFrame.TextRange.TrimText).ParagraphFormat.Bullet.Type = oshp.TextFrame.TextRange.ParagraphFormat.Bullet.Type
oshp.Delete
End If
Next i
End With
Next osld
End Sub
This may have some formatting issues that need to be addressed, but this will insert the hyperlinks that you are looking for. Code is likely not the cleanest, but it works. You will also need to set the vba to break only on unhandled errors, or it will break in the middle of the code. See here.
Class Module - Hyper
Private shp As Shape
Private chrStart As Integer
Private hypAddr As String
Private hypText As String
Private Sub Class_Initialize()
End Sub
Public Sub InitializeWithValues(newShp As Shape, newChrStart As Integer, newHypAddress As String, newHypText As String)
Set shp = newShp
chrStart = newChrStart
hypAddr = newHypAddress
hypText = newHypText
End Sub
Public Function getShape() As Shape
Set getShape = shp
End Function
Public Function getchrStart() As Integer
getchrStart = chrStart
End Function
Public Function getHypAddr() As String
getHypAddr = hypAddr
End Function
Public Function getHypText() As String
getHypText = hypText
End Function
Class Module - hyperColl
Private myCollection As Collection
Private Sub Class_Initialize()
Set myCollection = New Collection
End Sub
Public Sub Add_Item(newHyper As Hyper)
Dim newArray() As Hyper
If Me.Exists(newHyper.getShape().Name) Then
newArray = myCollection(newHyper.getShape().Name)
ReDim Preserve newArray(0 To UBound(newArray) + 1)
Set newArray(UBound(newArray)) = newHyper
myCollection.Remove (newHyper.getShape().Name)
myCollection.Add newArray, newHyper.getShape().Name
Else
ReDim newArray(0)
Set newArray(0) = newHyper
myCollection.Add newArray, newHyper.getShape().Name
End If
End Sub
Public Function GetArray(shapeName As String) As Hyper()
GetArray = myCollection(shapeName)
End Function
Public Function Exists(shapeName As String) As Boolean
Dim myHyper() As Hyper
On Error Resume Next
myHyper = myCollection(shapeName)
On Error GoTo 0
If Err.Number = 5 Then 'Not found in collection
Exists = False
Else
Exists = True
End If
Err.Clear
End Function
Regular Module (Call it whatever you want)
Sub textBoxFix()
Dim sld As Slide
Dim shp As Shape
Dim shp2 As Shape
Dim oHl As Hyperlink
Dim hypAddr As String
Dim hypText As String
Dim hypTextLen As Integer
Dim hypTextStart As Integer
Dim hypShape As Shape
Dim hypCollection As hyperColl
Dim newHyper As Hyper
Dim hypArray() As Hyper
Dim hypToAdd As Hyper
Dim i As Long
Dim j As Long
Dim bolCopy As Boolean
Set sld = ActivePresentation.Slides(1)
sld.CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(2)
Set hypCollection = New hyperColl 'Set the collection of arrays - 1 for each shape
Set shp = sld.Shapes(1)
For Each oHl In sld.Hyperlinks
If oHl.Type = msoHyperlinkRange Then 'Hyperlink is associated with part of a TextRange, not a whole shape
hypAddr = oHl.Address
hypText = oHl.TextToDisplay
hypTextLen = Len(hypText)
If TypeName(oHl.Parent.Parent) = "TextRange" Then
hypTextStart = oHl.Parent.Parent.start
Set hypShape = oHl.Parent.Parent.Parent.Parent
End If
Set newHyper = New Hyper
newHyper.InitializeWithValues hypShape, hypTextStart, hypAddr, hypText
hypCollection.Add_Item newHyper
End If
Next oHl
For j = sld.Shapes.Count To 1 Step -1
Set shp = sld.Shapes(j)
bolCopy = False
If j = 3 Then
Set shp2 = sld.Shapes.Placeholders.Item(1)
bolCopy = True
ElseIf j > 3 And shp.Type = msoTextBox Then
Set shp2 = sld.Shapes.Placeholders.Item(2)
bolCopy = True
End If
If bolCopy = True Then
shp2.TextFrame.TextRange.InsertBefore(shp.TextFrame.TextRange.TrimText).ParagraphFormat.Bullet.Type = shp.TextFrame.TextRange.ParagraphFormat.Bullet.Type
If hypCollection.Exists(shp.Name) Then
hypArray = hypCollection.GetArray(shp.Name)
For i = LBound(hypArray) To UBound(hypArray)
Set hypToAdd = hypArray(i)
With shp2.TextFrame.TextRange.Characters(hypToAdd.getchrStart, Len(hypToAdd.getHypText)).ActionSettings.Item(1)
.Action = ppActionHyperlink
.Hyperlink.Address = hypToAdd.getHypAddr
End With
Next i
End If
End If
shp.Delete
Next j
End Sub
I used OpiesDad's code as a starting point, and made some minor modifications. I was getting an error related to the GetArray function when textboxes didn't exist. In addition, I modified the code to run on all slides of the PPT. I also had to make some modifications to the TextBoxFix Sub because the content was being deleted, but wasn't populating in my Placeholders.
See my updates below:
Reused Class Module - Hyper
Removed "On Error GoTo 0" from the Exists Function in hyperColl
Revised TextBoxFix below:
Sub TextBoxFix()
Dim shp As Shape
Dim shp2 As Shape
Dim oHl As Hyperlink
Dim hypAddr As String
Dim hypText As String
Dim hypTextLen As Integer
Dim hypTextStart As Integer
Dim hypShape As Shape
Dim hypCollection As hyperColl
Dim newHyper As Hyper
Dim hypArray() As Hyper
Dim hypToAdd As Hyper
Dim i As Long
Dim j As Long
Dim bolCopy As Boolean
For Each sld In ActivePresentation.Slides
With ActivePresentation
sld.CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(2)
Set hypCollection = New hyperColl 'Set the collection of arrays - 1 for each shape
Set shp = sld.Shapes(1)
For Each oHl In sld.Hyperlinks
If oHl.Type = msoHyperlinkRange Then 'Hyperlink is associated with part of a TextRange, not a whole shape
hypAddr = oHl.Address
hypText = oHl.TextToDisplay
hypTextLen = Len(hypText)
If TypeName(oHl.Parent.Parent) = "TextRange" Then
hypTextStart = oHl.Parent.Parent.Start
Set hypShape = oHl.Parent.Parent.Parent.Parent
End If
Set newHyper = New Hyper
newHyper.InitializeWithValues hypShape, hypTextStart, hypAddr, hypText
hypCollection.Add_Item newHyper
End If
Next oHl
For j = sld.Shapes.Count To 1 Step -1
Set shp = sld.Shapes(j)
bolCopy = False
If j = 3 Then
sld.Shapes.Placeholders.Item(1).TextFrame.TextRange = shp.TextFrame.TextRange.Characters
sld.Shapes.Placeholders.Item(1).Visible = msoTrue
shp.Delete
ElseIf j > 3 And shp.Type = msoTextBox Then
sld.Shapes.Placeholders.Item(2).TextFrame.TextRange.InsertBefore(shp.TextFrame.TextRange.TrimText).ParagraphFormat.Bullet.Type = shp.TextFrame.TextRange.ParagraphFormat.Bullet.Type
If hypCollection.Exists(shp.Name) Then
hypArray = hypCollection.GetArray(shp.Name)
For i = LBound(hypArray) To UBound(hypArray)
Set hypToAdd = hypArray(i)
With sld.Shapes.Placeholders.Item(2).TextFrame.TextRange.Characters(hypToAdd.getchrStart, Len(hypToAdd.getHypText)).ActionSettings.Item(1)
.Action = ppActionHyperlink
.Hyperlink.Address = hypToAdd.getHypAddr
End With
Next i
End If
shp.Delete
End If
Next j
End With
Next sld
End Sub