As per the discussion in the question here: VBA Visio - locate text-based shapes with the same fill color
I would like to do this exercise in a bunch.
Therefore I've modified the code slightly, which now looks like this:
Sub finalsort4()
Dim vShp As Visio.Shape
Dim isText As Boolean
Dim colorColl As Collection
Dim shpColor As String, shpColor2 As String, shpColor3 As String, shpColor4 As String,
shpColor5 As String
Dim shpColor6 As String, shpColor7 As String, shpColor8 As String, shpColor9 As String,
shpColor10 As String
Dim filterColor As String, filterColor2 As String, filterColor3 As String, filterColor4 As
String, filterColor5 As String
Dim filterColor6 As String, filterColor7 As String, filterColor8 As String, filterColor9 As
String, filterColor10 As String
Set colorColl = New Collection
'Sort all shapes by fill color and locate "master" shape
For Each vShp In ActiveDocument.Pages("SLD").Shapes
'Reset Flags
isText = False
shpColor = ""
shpColor2 = ""
shpColor3 = ""
shpColor4 = ""
shpColor5 = ""
shpColor6 = ""
shpColor7 = ""
shpColor8 = ""
shpColor9 = ""
shpColor10 = ""
'Extract Shape color and text from subshape
Call getInfo(vShp, shpColor, isText, "*AA**")
Call getInfo(vShp, shpColor2, isText, "*AE**")
Call getInfo(vShp, shpColor3, isText, "*AK**")
Call getInfo(vShp, shpColor4, isText, "*AR**")
Call getInfo(vShp, shpColor5, isText, "*AU**")
Call getInfo(vShp, shpColor6, isText, "*AY**")
Call getInfo(vShp, shpColor7, isText, "*BC**")
Call getInfo(vShp, shpColor8, isText, "*BH**")
Call getInfo(vShp, shpColor9, isText, "*BM**")
Call getInfo(vShp, shpColor10, isText, "*BS**")
'Group shapes in collections by foreground color formula
If Not hasKey(colorColl, shpColor) Then colorColl.Add New Collection, shpColor
colorColl(shpColor).Add vShp
'Set filter color if our shape fulfills the text filter criteria
If isText Then filterColor = shpColor
If isText Then filterColor2 = shpColor2
If isText Then filterColor3 = shpColor3
If isText Then filterColor4 = shpColor4
If isText Then filterColor5 = shpColor5
If isText Then filterColor6 = shpColor6
If isText Then filterColor7 = shpColor7
If isText Then filterColor8 = shpColor8
If isText Then filterColor9 = shpColor9
If isText Then filterColor10 = shpColor10
Next vShp
'Place shapes of desired color at specified location
For Each vShp In colorColl(filterColor)
vShp.Cells("PinY") = 32
Next
For Each vShp In colorColl(filterColor2)
vShp.Cells("PinY") = 29
Next
For Each vShp In colorColl(filterColor3)
vShp.Cells("PinY") = 26
Next
For Each vShp In colorColl(filterColor4)
vShp.Cells("PinY") = 23
Next
For Each vShp In colorColl(filterColor5)
vShp.Cells("PinY") = 20
Next
For Each vShp In colorColl(filterColor6)
vShp.Cells("PinY") = 17
Next
For Each vShp In colorColl(filterColor7)
vShp.Cells("PinY") = 14
Next
For Each vShp In colorColl(filterColor8)
vShp.Cells("PinY") = 11
Next
End Sub
Just part of them moves to the correct position. Is there a way to elaborate this code more nicely?
UPDATE:
Based on the answer below I've tweaked the code, which looks like this:
Sub finalsort6()
Dim filterColors As Collection, colorColl As Collection
Dim textFilter As Collection, textFilters As Collection, isText As
String
Dim vShp As Visio.Shape
Const Y_OFFSET = 11 'Initial offset for YPin (mm)
Const Y_SPACING = 3 'Spacing between YPin placements (mm)
Set filterColors = New Collection 'Holds the filter shape colors
Set colorColl = New Collection 'Groups shapes by color
'Create array of text filters to look for (rearrange as necessary for positioning)
textFilters = Split("AA;AE;AK;AR;AU;AY;BC;BH;BM;BS", ";")
'Sort all shapes by fill color and locate "master" shape
For Each vShp In ActiveDocument.Pages("SLD").Shapes
'Reset Flags
isText = False
'Extract Shape color and text from subshape, testing for each filter criteria
For Each textFilter In textFilters
'Create dynamic pattern to match
Call GetInfo(vShp, shpColor, isText, "*" & textFilter & "**")
'Add filter color to list
If isText Then
filterColors.Add shpColor, textFilter
Exit For 'Match found: Exit textFilter loop
End If
Next
'Group shapes in collections by foreground color formula
If Not hasKey(colorColl, shpColor) Then colorColl.Add New Collection, shpColor
colorColl(shpColor).Add vShp
Next vShp
'Loop over filter shape colors
For i = 1 To filterColors.Count
'Place shapes of desired color at specified location
For Each vShp In colorColl(filterColors(i))
vShp.Cells("PinY") = Y_OFFSET + (i - 1) * Y_SPACING
Next
Next
End Sub
It doesn't work, unfortunately, I am getting the following error:
Argument not optional at the line:
textFilters = Split("AA;AE;AK;AR;AU;AY;BC;BH;BM;BS", ";")
I feel that I am pretty close to the solution, although I don't know what should be applied here.
Despite my comment on the OP, I've decided to provide an answer anyways. I don't currently have access to Visio and therefore can't test this. I'll leave troubleshooting as an exercise for the OP. A better implementation would be to rewrite getInfo()
or to format the Shapes to provide easy access to the filter/grouping criteria, but those aren't part of this question.
This assumes that each "filter shape" only occurs once.
Sub finalsort4()
Const Y_OFFSET = 11 'Initial offset for YPin (mm)
Const Y_SPACING = 3 'Spacing between YPin placements (mm)
Set filterColors = New Collection 'Holds the filter shape colors
Set colorColl = New Collection 'Groups shapes by color
'Create array of text filters to look for (rearrange as necessary for positioning)
textFilters = Split("AA;AE;AK;AR;AU;AY;BC;BH;BM;BS", ";")
'Sort all shapes by fill color and locate "master" shape
For Each vShp In ActiveDocument.Pages("SLD").Shapes
'Reset Flags
isText = False
'Extract Shape color and text from subshape, testing for each filter criteria
For each textFilter in textFilters
'Create dynamic pattern to match
Call getInfo(vShp, shpColor, isText, "*" & textFilter & "**")
'Add filter color to list
If isText then
filterColors.Add shpColor, textFilter
Exit For 'Match found: Exit textFilter loop
End IF
Next
'Group shapes in collections by foreground color formula
If Not hasKey(colorColl, shpColor) Then colorColl.Add New Collection, shpColor
colorColl(shpColor).Add vShp
Next vShp
'Loop over filter shape colors
For i = 1 to filterColors.Count
'Place shapes of desired color at specified location
For Each vShp In colorColl(filterColors(i))
vShp.Cells("PinY") = Y_OFFSET + (i-1) * Y_SPACING
Next
Next
End Sub