Log In
Register
Home
December 7, 2021
Offline
Hi -
I'm trying to size, align, and vertically stack all the slicers on a sheet.
I tried two approaches. First, I have code to loop thru the slicers, select them one by one, and then position them. I think the problem is that it's not adding slicers to the selection, but replacing one selection with the next. I'm also not sure it's actually moving anything at all!
Second I tried an array. That seems less prone to error than selecting objects. But I can't figure out how to add only the slicers to the array.
See attached sample XLS.
Thanks!
Trusted Members
Moderators
November 1, 2018
Offline
You could use something like this:
Sub Main()
Dim ws As Worksheet
Set ws = ActiveSheet
Call AlignSlicersVertical(ws)
End Sub
Sub AlignSlicersVertical(ByVal ws As Worksheet)
' Declare variable names and type for this procedure
Dim iNumShapes As Integer
iNumShapes = ws.DrawingObjects.Count
Dim shapeNames() As String
ReDim shapeNames(1 To iNumShapes)
Debug.Print "Shapes detected: " & iNumShapes
If iNumShapes = 0 Then Exit Sub
' Declare variable names and type for this procedure
Dim shp As Shape
Dim iNumSlicers As Integer
Dim lCnt As Long
Dim dTop As Double
Dim dLeft As Double
Dim dHeight As Double
Const dSPACE As Double = 8
With ws
For Each shp In ws.Shapes
If shp.Type = msoSlicer Then
iNumSlicers = iNumSlicers + 1
shapeNames(iNumSlicers) = shp.Name
End If
Next shp
Debug.Print "Slicers detected and selected: " & iNumSlicers
End With
If iNumSlicers > 0 Then
ReDim Preserve shapeNames(1 To iNumSlicers)
lCnt = 1
For Each shp In ws.Shapes.Range(shapeNames)
With shp
Debug.Print "Positioning Slicers: " & shp.Name
If lCnt > 1 Then
.Top = dTop + dHeight + dSPACE
.Left = dLeft
End If
dTop = .Top
dLeft = .Left
dHeight = .Height
End With
lCnt = lCnt + 1
Next shp
End If
End Sub
December 7, 2021
Offline
Thank you. I will review your approach above. Meanwhile, before reading your response, I ended up with what you see below. The problem is in red, where I try to move the slicers.
Sub Main()
Call AlignSlicersVertical(ActiveSheet.Index)
End Sub
Sub AlignSlicersVertical(ByVal SheetIndexNumber As Long)
DebugPrint "---"
DebugPrint "AlignSlicersVertical(" & SheetIndexNumber & ")"
' Code to exit if sheet is locked removed from here for forum
' Exit if there are no shapes
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets(SheetIndexNumber)
Dim iNumShapes As Integer
iNumShapes = ws.Shapes.Count
If iNumShapes = 0 Then Set ws = Nothing: Exit Sub
' Add slicers to a collection
Dim iNumSlicers As Integer
Dim shp As Shape
Dim colShapes As New Collection
With ws
For Each shp In ws.Shapes
If shp.Type = msoSlicer Then
iNumSlicers = iNumSlicers + 1 ' Count slicers
colShapes.Add shp ' Add slicers to collection
' Unlock the shape so it can be manipulated below
colShapes.Item(iNumSlicers).locked = False ' Unlock
DebugPrint "Proof shape is unlocked..... Slicer " & colShapes.Item(iNumSlicers).Name & " | Locked = " & colShapes.Item(iNumSlicers).locked
End If
Next shp
End With
' Position and size slicers in the collection
Dim lCnt As Long
Dim dTop As Double
Dim dLeft As Double
Dim dHeight As Double
Dim dWidth As Double
Dim chObj As ChartObject
Const dSPACE As Double = 2
dTop = Int(ws.ChartObjects(1).Top)
dLeft = Int(ws.ChartObjects(1).Left + ws.ChartObjects(1).Width + (3 * dSPACE))
dHeight = Int(ws.ChartObjects(1).Height / (iNumSlicers - 1)) ' Subtract 1 to ignore the "VALID" slcer, which we will hide
dWidth = Int(Application.InchesToPoints(2.7))
For lCnt = 1 To iNumSlicers
' All slicers share these properties
DebugPrint "Checkng Locked status again... Slicer (" & lCnt & " of " & iNumSlicers & "): " & colShapes.Item(lCnt).Name & " | Locked = " & colShapes.Item(lCnt).locked
colShapes.Item(lCnt).Height = dHeight ' THIS THROWS AN ERROR - SHAPE IS LOCKED?
colShapes.Item(lCnt).Width = dWidth
colShapes.Item(lCnt).Left = dLeft
If lCnt = 1 Then ' Position the first slcer at the top
colShapes.Item(lCnt).Top = dTop
ElseIf InStrRev(colShapes.Item(lCnt).Name, "VALID") Then ' Hide the VALID slicer
colShapes.Item(lCnt).Top = dTop + dSPACE
colShapes.Item(lCnt).Left = dLeft + dSPACE
colShapes.Item(lCnt).Height = dHeight - (2 * dSPACE)
colShapes.Item(lCnt).Width = dWidth - (2 * dSPACE)
colShapes(lCnt).Visible = msoFalse
colShapes(lCnt).ZOrder msoSendToBack
Else ' Position other slicers in a stack
colShapes.Item(lCnt).Top = colShapes.Item(lCnt - 1).Top + dHeight + dSPACE
colShapes.Item(lCnt).Left = dLeft
colShapes.Item(lCnt).Height = dHeight
colShapes.Item(lCnt).Width = dWidth
End If
Next lCnt
DoEvents
Set ws = Nothing
End Sub
1 Guest(s)
