Selecting objects based on unique entry in shape data (Prop.shapeKey)

[miless2111s]

Adding 1 more IF statement might help, if (pun intended) your pages have connector and/or lines, that is, OneD shapes.  The new IF statement immediately excludes these shapes from additional processing.

One of the target shape sets is a line so I don't think I can use that, thank you for the If/End if catch; you are right your edit is neater and more correct   In my testing, it didn't make any errors (what did you see when you say it didn't test properly?) however your way is better.

[miless2111s]

Yes, you got the idea right.

Great, I'll have a crack at that later

[miless2111s]

what is the difference between NameID and Name?  When I search using the Edit / Find option it will only pick up on Name, not NameID.  Does NameID always stay the same?  Am I "safer" using NameID and Name in terms of the shape references never changing if someone adds additional shapes etc?

[Croc]

NameID returns a unique name for the shape within the page.
The differences in NameID and Name can be seen in the example. Shown below are the NameID and Name for the same 6 shapes.
Three shapes are drawn, the other three are derived from the Rectangle master shape.

Code Select Expand

NameID Name
Sheet.3 Sheet.3
Sheet.5 Rectangle
Sheet.6 Rectangle.6
Sheet.7 Rectangle.7
Sheet.8 Sheet.8
Sheet.9 Sheet.9
In the following example, I have removed several shapes and added new ones.

Code Select Expand

Sheet.6       Rectangle.6
Sheet.7       Rectangle.7
Sheet.8       Sheet.8
Sheet.9       Sheet.9
Sheet.10      Rectangle.10
Sheet.11      Rectangle.11
Sheet.12      Rectangle.12
Sheet.13      Ellipse
Sheet.14      Ellipse.14

[miless2111s]

Croc
Am I able to save the ShapeKey text alongside the name reference in the Collection and then search on the ShapeKey text in the "doing" part of the code?   I ask as at the moment the code at the moment has to loop through the collections 300 times as it needs to find all items with 1 in the ShapeKey and move them to the back, then do the same with all items with 2 in etc:

Code Select Expand

    For N = 300 To 1 Step -1
        For Each itm In c
            If ActivePage.Shapes(itm).CellExistsU("Prop.ShapeKey", 0) Then
                ShapeKey = ActivePage.Shapes(itm).Cells("Prop.ShapeKey").ResultStr("")
                If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--b" Or ShapeKey = N & "--R" Or ShapeKey = "BL_link-" & N Then
                    ActiveWindow.Select ActivePage.Shapes(itm), visSelect
                    Debug.Print "added " & ActivePage.Shapes(itm).Name & " to selection"
                End If
            End If
         Next itm
            If ActiveWindow.Selection.Count <> 0 Then
                ActiveWindow.Selection.SendToBack
                ActiveWindow.DeselectAll
            End If
    Next N
    ActiveWindow.DeselectAll

This is understandably taking some time.  I assume it would be quicker if it could go straight to select item 1- and then 1--P nd then 1--B etc move them to the back and then select 2-, 2--P etc...

[Croc]

I will try to suggest several possible solutions ...
1. When creating a collection, you can combine the text NameID & <separator> & ShapeKey. And when selecting elements, separate them with the "Split" function.
2. You can collect all shape names with ShapeKey = 1 -... into one collection.
To another collection - with ShapeKey = 2 -...
etc.
Then collect all these collections into a collection of a higher level. Since you can put not only strings into a collection, but also any objects, including collections.
3. If the ShapeKey is unique, then you can use the key argument of the Collection.Add(item, key, before, after) method
In this case, when selecting from a collection, you need to use not a number, but a key value.
Instead of
For Each itm In c
  ActivePage.Shapes (itm)
or ActivePage.Shapes (c (i))
Will
ActivePage.Shapes (c("1-"))
ActivePage.Shapes (c("1-P"))
...
Perhaps it would be better to use method 1 in Sub RefreshData1(), and create a collection with a key in Sub CollectionFromData1() (method 3). To choose a solution, you need to know the features of your document: is the ShapeKey unique?, are there gaps in the numbering?, etc.

[miless2111s]

ShapeKey is unique.  There are no gaps in the ordering 1-300 for all the various 1-, 1--P, 1--B etc  (unless the user has accidentally deleted a shape).  There are other Shapekey sets with other naming conventions

I have been running a timing comparison of the two code sets and in a very counterintuitive way, the original code which cycles through everything is faster than the one using a collection!
Original Code: 79s (7.71, 65.5, 107.2, 75.86s)
collection code: 144s (159.87, 143.37, 118.3, 154.23s)

For Reference, the original code is:

Code Select Expand

Sub ReOrder_including_within_layer()

    Dim shp As Visio.Shape
    Dim ShapeKey As String
   
    Dim StartTime As Double
    Dim SecondsElapsed As Double
    StartTime = Timer
   
   
    Application.ScreenUpdating = False
    Application.DeferRecalc = True
    ActiveWindow.DeselectAll
   
    For N = 300 To 1 Step -1
        For Each shp In ActivePage.Shapes
            If shp.CellExistsU("Prop.ShapeKey", 0) Then
                ShapeKey = shp.Cells("Prop.ShapeKey").ResultStr("")
                If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--b" Or ShapeKey = N & "--R" Or ShapeKey = "BL_link-" & N Then
                    ActiveWindow.Select shp, visSelect
                End If
            End If
         Next shp
            If ActiveWindow.Selection.Count <> 0 Then
                ActiveWindow.Selection.SendToBack
                ActiveWindow.DeselectAll
            End If
    Next N
    ActiveWindow.DeselectAll

'Call ReOrder_Layers

   
Finalise:
    ActiveWindow.DeselectAll
    Application.ScreenUpdating = True
    Application.DeferRecalc = False
   
    SecondsElapsed = Round(Timer - StartTime, 2)
    MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation

End Sub

And the collection code is:

Code Select Expand

Public Sub WorkOperation()  'Executed multiple times
    Call CollectionFromData1
'   For Each itm In c   'NameId of target shapes only
'       Debug.Print ActivePage.Shapes(itm).NameID & ": " & ActivePage.Shapes(itm).Name
'   Next
    Dim StartTime As Double
    Dim SecondsElapsed As Double
    StartTime = Timer
   
    Dim ShapeKey As String
   
    Application.ScreenUpdating = False
    Application.DeferRecalc = True
    ActiveWindow.DeselectAll
   
    For N = 300 To 1 Step -1
        For Each itm In c
            If ActivePage.Shapes(itm).CellExistsU("Prop.ShapeKey", 0) Then
                ShapeKey = ActivePage.Shapes(itm).Cells("Prop.ShapeKey").ResultStr("")
                If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--b" Or ShapeKey = N & "--R" Or ShapeKey = "BL_link-" & N Then
                    ActiveWindow.Select ActivePage.Shapes(itm), visSelect
                    'Debug.Print "added " & ActivePage.Shapes(itm).Name & " to selection"
                End If
            End If
         Next itm
            If ActiveWindow.Selection.Count <> 0 Then
                ActiveWindow.Selection.SendToBack
                ActiveWindow.DeselectAll
            End If
    Next N
    ActiveWindow.DeselectAll

'Call ReOrder_Layers

   
Finalise:
    ActiveWindow.DeselectAll
    Application.ScreenUpdating = True
    Application.DeferRecalc = False
   
    SecondsElapsed = Round(Timer - StartTime, 2)
    MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub

[Croc]

miless2111s, I would like to look at your document to try to choose the optimal algorithm for performing the operation. The algorithm can be highly dependent on the specifics of the document.
If the document does not contain classified information, send it to me at gcroc@yandex.ru
If the original document contains confidential information, then perhaps you can make the most similar analogue that I could use for testing.

[wapperdude]

I'm wondering if the order of the  FOR loops were reversed if that might improve the speed.  Presently you have the "PAGE" loop iinide the "N" loop.  Try making the PAGE loop the outer loop and the N loop the inner.  It might be that calling each page is slower than looping thru the variable N. 

Just a thought.

[miless2111s]

I'm wondering if the order of the  FOR loops were reversed if that might improve the speed.  Presently you have the "PAGE" loop iinide the "N" loop.  Try making the PAGE loop the outer loop and the N loop the inner.  It might be that calling each page is slower than looping thru the variable N. 

Just a thought.

I am struggling with the reversal of logic... At the moment the code sets the number to look for (say 10) and looks at all shapes, if it finds a matching "10" it selects it and then when all shapes have been inspected sends all the "10" items to the back.  Then it starts again for "9".   How would this work for looking at each shape only once?  Not saying that you're wrong only that my brain hasn't got to where you are

[wapperdude]

Let me say it..."My brain was wrong."  My excuse...hadn't had morning coffeeeeeeee yet.  Looking back at what I said, makes no sense.  Sorry.

[Croc]

See how this macro will work for you.
Macro Sub WorkOperation_test2() works in one pass. Saving in the Data1 field is not used. Collections are not used.
The data is accumulated in one pass in the Arr(300) array, then the shapes are "SendToBack" for each row of the array.
This should work quickly.

Code Select Expand

Public Sub WorkOperation_test2()
    Dim Arr(300)
    For i = LBound(Arr) To UBound(Arr)
        Arr(i) = ""
    Next
   
    Dim ShapeKey As String
    For Each shp In ActivePage.Shapes
        If shp.CellExistsU("Prop.ShapeKey", 0) Then
            ShapeKey = shp.Cells("Prop.ShapeKey").ResultStr("")
            arrN = Split(ShapeKey, "-")
            If UBound(arrN) = 1 Then
                If IsNumeric(arrN(0)) Then
                If CInt(arrN(0)) > 0 And CInt(arrN(0)) < 301 Then    '   "1-"
                    N = arrN(0)
                    If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--b" Or ShapeKey = N & "--R" Then
                        Arr(N) = Arr(N) & shp.NameID & ";"
                    End If
                End If
                End If
                If IsNumeric(arrN(1)) Then
                If CInt(arrN(1)) > 0 And CInt(arrN(1)) < 301 Then    '   "BL_link-1"
                    N = arrN(1)
                    If ShapeKey = "BL_link-" & N Then
                        Arr(N) = Arr(N) & shp.NameID & ";"
                    End If
                End If
                End If
            End If
            If UBound(arrN) = 2 Then    '   "1--p", "1--b", "1--R"
                If IsNumeric(arrN(0)) Then
                If CInt(arrN(0)) > 0 And CInt(arrN(0)) < 301 Then
                    N = arrN(0)
                    If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--b" Or ShapeKey = N & "--R" Then
                        Arr(N) = Arr(N) & shp.NameID & ";"
                    End If
                End If
                End If
            End If
        End If
    Next
   
    Dim StartTime As Double
    Dim SecondsElapsed As Double
    StartTime = Timer
   
   
    Application.ScreenUpdating = False
    Application.DeferRecalc = True
    ActiveWindow.DeselectAll
   
    For i = UBound(Arr) To 1 Step -1
        arrN = Split(Arr(i), ";")
        For j = LBound(arrN) To UBound(arrN) - 1
            ActiveWindow.Select ActivePage.Shapes(arrN(j)), visSelect
        Next
        If ActiveWindow.Selection.Count <> 0 Then
            ActiveWindow.Selection.SendToBack
            ActiveWindow.DeselectAll
        End If
    Next
    ActiveWindow.DeselectAll

'Call ReOrder_Layers
Finalise:
    ActiveWindow.DeselectAll
    Application.ScreenUpdating = True
    Application.DeferRecalc = False
   
    SecondsElapsed = Round(Timer - StartTime, 2)
    MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub

[miless2111s]

Let me say it..."My brain was wrong."  My excuse...hadn't had morning coffeeeeeeee yet.  Looking back at what I said, makes no sense.  Sorry.

phew, for once it wasn't me

[wapperdude]

As an FYI, prior to Croc's most recent development, in your code, you step N from max value to min stepping -1.  Since nothing is being deleted, there is no indexing ambiguity and stepping N from 1 to max value is permissible.  Turns out, stepping down in value actually takes longer than the normal stepping up in value.

Don't know how much this will save in time.  Nice of Croc to include a "built-in" elapsed time display.

[miless2111s]

As an FYI, prior to Croc's most recent development, in your code, you step N from max value to min stepping -1.  Since nothing is being deleted, there is no indexing ambiguity and stepping N from 1 to max value is permissible.  Turns out, stepping down in value actually takes longer than the normal stepping up in value.

Don't know how much this will save in time.  Nice of Croc to include a "built-in" elapsed time display.

The reason that I step down is I want items with a higher reference to be placed over the top of those with a lower reference.  I don't want to use "move to front" as if the user has placed anything non-original in the summary then my re-ordering macro can not hide it.