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

[miless2111s]

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.

You are absolutely correct, this does run * a lot* faster   16 seconds against the PB for 58 seconds for my original code   Excellent.  A lovely use of an array, populating as you go through the shapes, genius.   There's a lot to unpack and I have to go now, but I will get back to it tomorrow and try to ask some intelligent questions to better understand what it is doing at each stage so I can continue my learning curve.
Thank you very much for the time and effort you've given me on this

[miless2111s]

Croc, sorry for the delay in getting back to you, the week went nuts

Can I check my understanding of what the code is doing to make sure I am learning?   I have some questions which I show in italics and I will pull out at the bottom for ease.

Code Select Expand

   For Each shp In ActivePage.Shapes
        If shp.CellExistsU("Prop.ShapeKey", 0) Then
            ShapeKey = shp.Cells("Prop.ShapeKey").ResultStr("")
            arrN = Split(ShapeKey, "-")   ' splits ShapeKey into parts so it could be (1) or (1,,p) or (BL_link, 1)
            If UBound(arrN) = 1 Then  'counts how many items are in the array, if 1 (i.e. the Shapekey was 1 or 100 or Fred) then it continues with the next code, if not it jumps a [b]A[/b]
                If IsNumeric(arrN(0)) Then  'checks that the contents of the array is numeric (i,e, ignores Fred)
                If CInt(arrN(0)) > 0 And CInt(arrN(0)) < 301 Then    '   "1-"   'checks that the number is between 1 and 300
                    N = arrN(0)   'sets the location in arrN to the number shown in ShapeKey (1 or 100)
                    If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--b" Or ShapeKey = N & "--R" Then  [i]'Why is it checking for these?  Don't the preceding steps ensure that it will be 1, 2,50 or 300 etc)?[/i]
                        Arr(N) = Arr(N) & shp.NameID & ";"  'updates arr(n) with the ShapeKey reference at the appropriate place in the array.
                    End If
                End If
                End If
                If IsNumeric(arrN(1)) Then   'checks the second position in the array is numeric (fred-1 or BL_link-1)  [i] How has this been triggered given it is in the uBound(arrN) = 1 section and BL_link-1 would have split into BL_Link and 1 which would count as 2?[/i]
                If CInt(arrN(1)) > 0 And CInt(arrN(1)) < 301 Then    '   "BL_link-1"
                    N = arrN(1)
                    If ShapeKey = "BL_link-" & N Then  ' ignores "fred-1" and only processes if ShapeKey = BL_link-1
                        Arr(N) = Arr(N) & shp.NameID & ";"   [i]'will this not overwrite Arr(1) = "1-" with "BL_Link-1"?[/i]
                    End If
                End If
                End If
            End If
            If UBound(arrN) = 2 Then    '   "1--p", "1--b", "1--R"   [b]A[/b]
                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 [i]'is Shapekey = N redundant here?[/i]
                        Arr(N) = Arr(N) & shp.NameID & ";"
                    End If
                End If
                End If
            End If
        End If
    Next


Questions pulled out:

   
• When the 1st time that ShapeKey = N & "-" etc appears is this redundant given what the previous steps are checking that there is only a number in ShapeKey?
• SOLVED: How is "If IsNumeric(arrN(1)) Then  " triggered when it is within the IF loop that checks that ShapeKey only contains something like 1- or 200-.  I hadn't appreciated that UBOUND returns the index of the last item rather than the number of items in the array.  I think this is because I normally use arrays starting at 1 rather than 0.
• SOLVED: Why doesn't Arr(N) = Arr(N) & shp.NameID & ";" overwrite the previous entry?  Or is this adding onto the listing in that location of the array?  so we have 1-;BL_Link-1 etc? - this is exactly what is happening and I learnt yet another thing today
• Is the test "ShapeKey = N" redundent the second time that the tests "If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--b" Or ShapeKey = N & "--R"" appears? or is this needed for some reason?

This is very a very clever use of an array and I am working my way towards understanding exactly how it all works

[Croc]

First we create an array of 300 empty elements.
Then, in a loop, we look through the shapes and fill in the elements of the array.
But the shapes come in random order. To determine the position in the array, we must select a number from the cell "Prop.ShapeKey" - N. Thus, at the end we will get an array with gaps - not all elements will be filled.
In addition, several shape names need to be packed into one array row. In this case, the newly found value and the separator ";" are added to the end of the existing string. This is the operation Arr(N) = Arr(N) & shp.NameID & ";". As a result, the row will contain all the names of shapes related to the same number N.
The algorithm is imperfect, since the very last character ";" line will be redundant. But I remember it and take it into account in the statement "For j = LBound(arrN) To UBound(arrN)-1". That is why UBound(arrN)-1 is here.
Now about the IsNumeric function.
We know that N can occur in different places in the "Prop.ShapeKey" field - at the beginning or at the end. How to choose this number?
We can go through all the characters sequentially, find one or two "-" separators, then check which part is a number.
Or We can split the ShapeKey string with the "Split" function into several parts. There will be 2 or 3 such parts. I chose this method. Moreover, I did not optimize the algorithm, I just wanted to check whether it is suitable in principle.
The number selection algorithm consists of two successive checks, the first check consisting of two parts:
1. If UBound(arrN) = 1. The array contains 2 elements. This is for the values ​​"N-" and "BL_link-N". "N-" = N, <empty>. "BL_link-N" = BL_link, N.
1a. If IsNumeric(arrN(0)). The first element is a number. So the format is "N-".
1b. If IsNumeric(arrN(1)). The second element is a number. So the format is "BL_link-N".
2. If UBound(arrN) = 2. The array contains 3 elements. This is for the values ​​"N--p", "N--b", etc. "N--p" = N, <empty>, p.

[Croc]

There is also a check "If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--b" Or ShapeKey = N & "--R"
This check came about because I don't know the exact requirements for the algorithm.
It assumes that "N--p","N--b", "N--R" are valid values, and "N--f", "N--g"... is not in the list of valid values.

[miless2111s]

Hi Croc
Thanks for the tutorial on your excellent "massive array" code   I think I understand most if not all of it now. 
I have run into an issue I am struggling with.  During the execution of the code I used debug.print to see what was going on however it ran out of space so I outputted the contents of arr() to a text file using the code below and it showed that I am either missing some items or have duplicates.   This isn't in itself an issue as I can fix this.

Code Select Expand

Public Sub Cat_1_to_300_with_issues()
    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
   
'debugprint items with missing or to many entries
    For S = 1 To 300
        arrN = Split(Arr(S), ";")
        If UBound(arrN) <> 4 Then
            For j = LBound(arrN) To UBound(arrN) - 1
                op = ActivePage.Shapes(arrN(j)).Cells("Prop.ShapeKey").ResultStr("") & "; " & op
            Next j
        Debug.Print "Ref: " & S & ": " & op
        op = ""
        End If

    Next S

'print out all shapes to a text file to allow me to see what is missing / repeated in the array
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim Fileout As Object
    Set Fileout = fso.CreateTextFile("C:\SummaryPro\Temp working area - always transfer back to one drive at COP\output.txt", True, True)
   

    For i = 1 To UBound(Arr)
        arrN = Split(Arr(i), ";")
        For j = LBound(arrN) To UBound(arrN) - 1
            op = ActivePage.Shapes(arrN(j)).Cells("Prop.ShapeKey").ResultStr("") & "; " & op
        Next j
            Fileout.write op
            Fileout.write Chr(13) & Chr(10)
            op = ""
    Next i
    Fileout.Close
   
Finalise:
    ActiveWindow.DeselectAll
    Application.ScreenUpdating = True
    Application.DeferRecalc = False
   
    SecondsElapsed = Round(Timer - StartTime, 2)
    'MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
    MsgBox "all done"
End Sub

The issue is that when I use a simpler code to output everything on the page it shows that the "missing" items (for instance 201--P to 300-P, 15--P, 57--Pand 115--P) are actually present on the page but they don't seem to have been collected by the output code.

Code Select Expand

Sub Cat_all_shapes()
    Application.ScreenUpdating = False
    Application.DeferRecalc = True
    ActiveWindow.DeselectAll
   
'setup print out to text file
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim Fileout As Object
    Set Fileout = fso.CreateTextFile("C:\SummaryPro\Temp working area - always transfer back to one drive at COP\output_all_shapes.txt", True, True)


'identify shapes
    For Each shp In ActivePage.Shapes
        If shp.CellExistsU("Prop.ShapeKey", 0) Then
            ShapeKey = shp.Cells("Prop.ShapeKey").ResultStr("")
            Fileout.write ShapeKey
            Fileout.write Chr(13) & Chr(10)
        End If
    Next shp

Finalise:
    ActiveWindow.DeselectAll
    Application.ScreenUpdating = True
    Application.DeferRecalc = False
    MsgBox "all shapes printed out"
End Sub

Have I done something silly in my "print out" code showing what arr(N) is containing?  Or is there something odd about the items which are missing?  They tend to appear fairly far down the "all shapes" output - starting at item 1772 and running till 1877

[Croc]

You asked a question about the condition

Code Select Expand

If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--B" Or ShapeKey = N & "--R"
This condition considers ShapeKey = 201--p to be correct. But 201--P is not the same as 201--p. Therefore, 201--P is considered invalid and discarded.
If all combinations of N & <letter> are correct, then check
If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--B" Or ShapeKey = N & "--R"
needs to be removed from the code.
If you only want to add "P", then you need to add one more Or condition. That is, use

Code Select Expand

If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--P" Or ShapeKey = N & "--B" Or ShapeKey = N & "--R"

[miless2111s]

Oh for goodness sake! how could I have missed the capital!? Thank you for that.