I have a problem with deleting tables from all slides in a presentation.
At first the program is counting how much shapes are on the slide.
If the shape is a table delete it.
An error appears. 5 shapes are counted at the beginning. Later only 3 left because 2 tables were got deleted. I dont understand why. n_shapes is counting the shapes before the loop but I think Powerpoint is changing it dynamic.
Anyone an idea how to fix it?
Sub tab_del()
Dim n_shapes As Integer
Dim shape_count As Integer
Dim n_slides As Integer
Dim slide_count As Integer: slide_count = ActivePresentation.Slides.Count
For n_slides = 1 To ActivePresentation.Slides.Count
With ActivePresentation.Slides(n_slides).Shapes
n_shapes = .Count
For shape_count = 1 To n_shapes
If .Item(shape_count).Type = msoTable Then .Item(shape_count).Delete
Next shape_count
End With
Next n_slides
End Sub
Related
I have 3 text boxes that are created on a slide via vba. this means that they will all start with the name "TextBox" but the numbers behind the name will be different every time. these are the only text boxes on the slide
I want to use vba to group all text boxes together.
no need to change anything, just group them so they move as a group if needed.
I figured it out
I knew I was only going to have 3 text boxes at a time so this worked. basically since the text boxes could end in any number, I renamed them to box1, box2, box3. and then grouped the box shapes
Dim SLD As Slide
Dim D As Long
Dim T As Integer
Set SLD = ActivePresentation.Slides(9)
T = 1
For D = SLD.Shapes.Count To 1 Step -1
If SLD.Shapes(D).Type = msoTextBox Then
SLD.Shapes(D).Name = "Box" & T
T = T + 1
End If
Next
SLD.Shapes.Range(Array("Box1", "Box2", "Box3")).Group
I'm looking for a way to have three different colors in the same line chart of a diagram in Excel, depending on the values themselves or where they are from (from which sheet f.e).
Till now, I have the following code:
Sub ChangeColor()
Dim i As Integer
Dim IntRow As Integer
Dim r As Range
ActiveSheet.ChartObjects("Cash").Activate
ActiveChart.SeriesCollection(1).Select
IntRow = ActiveChart.ChartObjects("Cash").Count
For i = 2 To IntRow
Set r = Cells(2, i)
If r.Value < 3000 Then
Selection.Border.ColorIndex = 5
Else
Selection.Border.ColorIndex = 9
End If
Next
End Sub
However, the if statement is not considered and the color of the whole line changes only whenever I change the first ColorIndex. I have no idea, how to color parts of the line depending on the values in the underlying table.
Moreover, by defining IntRow as ActiveChart.ChartObjects("Cash").Count I'm not able to get the length of my array. This problem can be solved by manual counting and declaring IntRow as an Integer, however, the version above seems nicer (if that is possible of course).
I appreciate any help! Thank you.
Alexandra
You can read the values directly from the chart series:
Sub ChangeColor()
Dim cht As Chart, p As Point, s As Series
Dim i As Integer
Dim numPts As Long
'access the chart directly - no select/activate required
Set cht = ActiveSheet.ChartObjects("Cash").Chart
'reference the first series
Set s = cht.SeriesCollection(1)
'how many points in the first series?
numPts = s.Points.Count
'loop over the series points
For i = 1 To numPts
Set p = cht.SeriesCollection(1).Points(i)
p.Border.ColorIndex = IIf(s.Values(i) < 3000, 5, 9)
Next
End Sub
Recently, in an interview I encountered a question in VBA. The question is:
Write a program to sort the shapes in a worksheet, like for example : I have various shapes like circle, triangle, rectangle, pentagon... This needs to be sorted and placed one below the other.
I tried with Shapes object and msoshapeRectangle method. But it didnt work.
Could you please tell me is this possible to be done?
Thanks
It was an interesting challenge, so I did it. Might as well post the result (commented for clarity):
Sub tgr()
'There are 184 total AutoShapeTypes
'See here for full list
'https://msdn.microsoft.com/VBA/Office-Shared-VBA/articles/msoautoshapetype-enumeration-office
Dim aShapeTypes(1 To 184) As String
Dim ws As Worksheet
Dim Shp As Shape
Dim i As Long, j As Long
Dim vShpName As Variant
Dim dLeftAlign As Double
Dim dTopAlign As Double
Dim dVerticalInterval As Double
Dim dHorizontalInterval As Double
Dim dPadding As Double
Set ws = ActiveWorkbook.ActiveSheet
'Sort order will be by the AutoShapeType numerical ID
'Using this, shapes will be sorted in this order (incomplete list for brevity):
' Rectangle, Parallelogram, Trapezoid, Diamond, Rounded rectangle, Octagon, Isosceles triangle, Right triangle, Oval, Hexagon
'Note that you can use a Select Case to order shapes to a more customized list
'I use this method to put the -2 (indicates a combination of the other states) at the bottom of the sort order
For Each Shp In ws.Shapes
Select Case Shp.AutoShapeType
Case -2: aShapeTypes(UBound(aShapeTypes)) = aShapeTypes(UBound(aShapeTypes)) & "||" & Shp.Name
Case Else: aShapeTypes(Shp.AutoShapeType) = aShapeTypes(Shp.AutoShapeType) & "||" & Shp.Name
End Select
Next Shp
'Now that all shapes have been collected and put into their sort order, perform the actual sort operation
'Adjust the alignment and vertical veriables as desired
'The Padding variable is so that the shapes don't start at the very edge of the sheet (can bet set to 0 if that's fine)
'I have it currently set to sort the shapes vertically, but they can be sorted horizontally by uncommenting those lines and commenting out the vertical sort lines
dPadding = 10
dLeftAlign = 5
dTopAlign = 5
dVerticalInterval = 40
dHorizontalInterval = 40
j = 0
For i = LBound(aShapeTypes) To UBound(aShapeTypes)
If Len(aShapeTypes(i)) > 0 Then
For Each vShpName In Split(Mid(aShapeTypes(i), 3), "||")
With ws.Shapes(vShpName)
'Vertical Sort
.Left = dLeftAlign
.Top = j * dVerticalInterval + dPadding
'Horizont Sort
'.Top = dTopAlign
'.Left = j * dHorizontalInterval + dPadding
End With
j = j + 1
Next vShpName
End If
Next i
End Sub
I am writing a VBA code that goes through a defined matrix size and filling cells randomly within its limits.
I got the code here from a user on stackoverflow, but after testing it I realized that it does not fit for avoiding duplicate filling, and for instance when filling 5 cells, I could only see 4 cells filled, meaning that the random filling worked on a previously filled cell.
This is the code I'm working with:
Dim lRandom As Long
Dim sCells As String
Dim sRandom As String
Dim rMolecules As Range
Dim i As Integer, j As Integer
Dim lArea As Long
lArea = 400 '20x20
'Populate string of cells that make up the container so they can be chosen at random
For i = 1 To 20
For j = 1 To 20
sCells = sCells & "|" & Cells(i, j).Address
Next j
Next i
sCells = sCells & "|"
'Color the molecules at random
For i = 1 To WorksheetFunction.Min(5, lArea)
Randomize
lRandom = Int(Rnd() * 400) + 1
sRandom = Split(sCells, "|")(lRandom)
Select Case (i = 1)
Case True: Set rMolecules = Range(sRandom)
Case Else: Set rMolecules = Union(rMolecules, Range(Split(sCells, "|")(lRandom)))
End Select
sCells = Replace(sCells, "|" & sRandom & "|", "|")
lArea = lArea - 1
Next i
rMolecules.Interior.ColorIndex = 5
Using this same exact code which works perfectly, WHAT can I insert and WHERE do I do that so that the code would check if a cell is previously already filled with a string or a color?
I feel as though this code I'm looking for should be right before
rMolecules.Interior.ColorIndex = 5
But I'm not sure what to type.
EDIT
From the comments I realized that I should be more specific.
I am trying to randomly fill cells with the blue color (.ColorIndex = 5), but what I need to check first is if the randomizing hadn't marked a cell twice, so that for instance in this case, if I want to mark 5 different cells, it marks only 4 of them because of a duplicate and thus fills only 4 cells with the blue color. I need to avoid that and make it choose another cell to mark/fill.
I'd appreciate your help.
Keep the cells you use in a Collection and remove them as you fill the random cells:
Sub FillRandomCells(targetRange As Range, numberOfCells As Long)
' populate collection of unique cells
Dim c As Range
Dim targetCells As New Collection
' make sure arguments make sense
If numberOfCells > targetRange.Cells.Count Then
Err.Raise vbObjectError, "FillRandomCells()", _
"Number of cells to be changed can not exceed number of cells in range"
End If
For Each c In targetRange.Cells
targetCells.Add c
Next
' now pick random 5
Dim i As Long, randomIndex As Long
Dim upperbound As Long
Dim lowerbound As Long
For i = 1 To numberOfCells
lowerbound = 1 ' collections start with 1
upperbound = targetCells.Count ' changes as we are removing cells we used
randomIndex = Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
Set c = targetCells(randomIndex)
targetCells.Remove randomIndex ' remove so we don't use it again!
c.Interior.Color = 5 ' do what you need to do here
Next
End Sub
Sub testFillRandomCells()
FillRandomCells ActiveSheet.[a1:t20], 5
FillRandomCells ActiveSheet.[b25:f30], 3
End Sub
EDIT: Changed to make the target range and number of changed cells configurable as arguments to a function. Also added error checking (always do that!).
Why not build a list of random numbers and place in a Scripting.Dictionary, one can use the Dictionary's Exist method to detect duplicates, loop through until you have enough then you can enter your colouring code confident that you have a unique list.
I have a PowerPoint slide with 5 shapes on it. I would like to do different things with theses shapes in a macro. How can I change one of these shapes by using the shape ID? For example, I have two shapes with a name of "Title 1" but I want to use the one with an ID of 15.
Here is my code:
Sub size_n_spread_v()
Dim j As Integer
Dim sld As Slide
Dim SldId As Long
gap = std_gap
SldId = ActiveWindow.View.Slide.SlideIndex
Set sld = ActivePresentation.Slides(SldId)
Call SortMultArray
new_dim = (total_dim - gap * (lngRow - 1)) / lngRow
'This works but is not specific:
'sld.Shapes.("Title 1").Height = new_dim
'This would hopefully be specific but the syntax does not work Please HELP!
'sld.Shapes.("Title 1").Id(15).Height = new_dim
End Sub
Does someone know the right syntax to change the shape via ID?
I don't know of a way, but you could write a simple helper function that you could then use throughout your project to make things easier on yourself. Something like this would work:
Public Function GetShapeById(s As Slide, n As String, id As Long) As Shape
Dim objShape As Shape
For Each objShape In s.Shapes
If StrComp(objShape.Name, n, vbTextCompare) = 0 And objShape.Id = id Then
Set GetShapeById = objShape
Exit Function
End If
Next
End Function
Then you could use it like so:
Sub size_n_spread_v()
....
' Instead of:
sld.Shapes.("Title 1").Id(15).Height = new_dim
' Use:
GetShapeById(sld, "Title 1", 15).Height = new_dim
End Sub
The function mentioned above is the only way to get a shape by Id. You have to search through the Shapes collection as there is no equivalent ShapeIndex as there is for SlideIndex. The other solution to find a specific shape is to uniquely identify shapes by adding your own Tag but this is a more complex solution.