macro very slow and getting slower. 2

[N1GHTEYES]

This is a weird one.

I have a macro which is taking a surprisingly long time to accomplish fairly simple tasks. Furthermore, each time I run it, even though it is running on the same data, it takes longer.

The workbook has several sheets but the two relevant ones are "Kids Cascade" and "KCtext". On "Kids Cascade" there is a diagram consisting of text boxes linked by connectors.

The macro:
1 creates a list of which connectors lead into and out of each shape
2 finds the "top" shape - i.e. the one with no input connectors
3 tracks down through each shape's connectors to the next shape
recursively to create a complete list of each shape name in order
4 clears the existing data on KCtext sheet
5 copies the text from each box, in tree order onto the KC sheet, such that the column number into which the text is written is equal to the number of "branches" that shape is down from the top
6 creates a hyperlink from each cell thus written back to the topleft cell of the shape from which the cell text came
7 creates a hyperlink from each shape to the cell in KCtext which has that shape's text
8 uses the group and outline feature to recursively group the tree "branches" on KCtext.

Starting with a freshly loaded workbook, that process took 44s when there were 389 shapes on the Kids Cascade sheet. I then ran the macro again, and it took 55s. Subsequent run times, in seconds, were:
61
72
82
92
103
97 *1
127
130
141
151
161
172
158 *2
163
172
At this point I lost the will to live.

*1 between this run and the previous one I manually deleted all the cells on KCtext.

*2 between this run and the previous one I changed the code to clear KCtext from a version where I delete the UsedRange to one where I delete all the cells.

I put some timer code in there to see how long the various bits were taking. The two slow parts are:

a writing the text on KCtext sheet and creating the hyperlinks
b creating the group outline hierarchy.

These two parts take very nearly the same length of time and grow in time at the same rate.

The rest (creating the connector list etc) is practically instantaneous.

I've tried running it both with the code window open and closed. This seems to make little or no difference. I've also tried calling the macro in different ways:
from the workbook menu (tools, macros...)
from a button I put on the Kids Cascade sheet
using a keyboard shortcut assigned to the macro
pressing F5 from the code window
using the IDE menu (run...)

None of these methods make an appreciable difference to the running time.


Here is the code for the macro:

Sub Create_KC_text()
    On Error Resume Next
    Application.ScreenUpdating = False
    
    Dim i As Long, shpcount As Long
    Dim now As Single, start As Single
    Dim report As String
    now = Timer()
    start = now
    CreateConnectorList
    
    report = "made connector list in " & Format(Timer() - now, "0.00") & "s"
    now = Timer()

    shpcount = shpconlist.Count
    For i = 1 To shpcount
        If shpconlist.Item(i).up.Count = 0 And shpconlist.Item(i).down.Count > 0 Then
            Worksheets("Kids Cascade").Shapes(shpconlist.Item(i).name).Select
            Exit For
        End If
    Next i
    
    report = report & vbCrLf & "found top of tree in " & Format(Timer() - now, "0.00") & "s"
    now = Timer()

    Dim shp As Shape
    Dim r As Long, c As Long, numshapes As Long
    r = 1
    c = 1
    numshapes = ActiveSheet.Shapes.Count
    ReDim namelist(1 To numshapes) As Variant
    ReDim MyNames(1 To numshapes) As Variant
    For Each shp In Selection.ShapeRange
        Get_Leg shp, c
        If Err.Number <> 0 Then Err.Clear
    Next shp
    ReDim Preserve MyNames(1 To namecount) As Variant
    ReDim Preserve namelist(1 To namecount) As Variant
    Dim maxcol As Long

    report = report & vbCrLf & "created name lists in " & Format(Timer() - now, "0.00") & "s"
    now = Timer()
    
    Dim op_r As Long, txtlen As Long
    Dim txt As String
    Dim cascadesheet As Worksheet, textsheet As Worksheet
    Set cascadesheet = Worksheets("Kids Cascade")
    Set textsheet = Worksheets("KC_Text")
    Dim colr As Long
    cascadesheet.Hyperlinks.Delete
    
    report = report & vbCrLf & "deleted cascade HLs in " & Format(Timer() - now, "0.00") & "s"
    now = Timer()
    
    With textsheet
        .Cells.Delete Shift:=xlUp
        report = report & vbCrLf & "deleted kctext cells in " & Format(Timer() - now, "0.00") & "s"
        now = Timer()
        
        .Hyperlinks.Delete
        report = report & vbCrLf & "deleted kctext HLs in " & Format(Timer() - now, "0.00") & "s"
        now = Timer()

        For r = 1 To namecount
            txt = ""
            Set shp = cascadesheet.Shapes(namelist(r)(0))
            With shp
                If .connector = False Then
'                    If .AlternativeText = "" Then
'                        If Err.Number <> 0 Then Err.Clear
'                    Else
                        op_r = op_r + 1
                        txt = .AlternativeText
                        txt = Mid(txt, 10, Len(txt) - 9)
                        colr = shp.DrawingObject.Interior.Color
'                    End If
                End If
            End With
            If txt <> "" Then
                .Cells(op_r, namelist(r)(2)) = txt
                .Cells(op_r, namelist(r)(2)).Interior.Color = colr
                .Hyperlinks.Add _
                    Anchor:=.Cells(op_r, namelist(r)(2)), _
                    Address:="", _
                    SubAddress:="'Kids Cascade'!" & cascadesheet.Shapes(namelist(r)(0)).TopLeftCell.Address, _
                    TextToDisplay:=txt
                cascadesheet.Hyperlinks.Add _
                    Anchor:=cascadesheet.Shapes(namelist(r)(0)), _
                    Address:="", _
                    SubAddress:="KC_Text!" & .Cells(op_r, namelist(r)(2)).Address
            End If
        Next r

        report = report & vbCrLf & "wrote KC_text and created hyperlinks in " & Format(Timer() - now, "0.00") & "s"
        now = Timer()
        
        With .UsedRange
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
            .ColumnWidth = 1.71
        End With
        AddIndexColumn
    End With
    CreateGroupHierarchy textsheet, 1, 1
    report = report & vbCrLf & "created group hierarchy in " & Format(Timer() - now, "0.00") & "s"
    now = Timer()

    Err.Clear
    Application.ScreenUpdating = True
    
    'debug
    report = report & vbCrLf & "total time taken " & Format(Timer() - start, "0.00") & "s"
    report = report & vbCrLf & "Number of shapes = " & Format(numshapes, "###")
    report = report & vbCrLf & "Name Count = " & Format(namecount, "###")
    namecount = 0
    Set shpconlist = Nothing
    Set textsheet = Nothing
    Set cascadesheet = Nothing
    Set shp = Nothing
    MsgBox report, vbOKOnly, "Timings"

End Sub

Here is the code for CreateGroupHierarchy

Public Sub CreateGroupHierarchy(wksht As Worksheet, _
                                indexcol As Long, _
                                startrow As Long)
'This sub uses the excel inbuilt group and outline process to display the data on the KC_text sheet
Dim maxrow As Long, lastrow As Long, startval As Long
Dim r As Long, i As Long, j As Long
Dim maxindex As Long
Dim ingroup As Boolean
With wksht
    .Cells.ClearOutline
    maxrow = .UsedRange.Rows.Count
    startval = .Cells(startrow, indexcol)
    For r = startrow To maxrow
        If .Cells(r, indexcol) > maxindex Then
            maxindex = .Cells(r, indexcol)
        End If
    Next r

    For i = maxindex To startval + 1 Step -1
        ingroup = False
        For r = startrow To maxrow
            If .Cells(r, indexcol) = i Then
                If Not ingroup Then
                    ingroup = True
                    grouprowstart = r
                End If
            Else
                If .Cells(r, indexcol) < i And ingroup Then
                    .Rows(Trim(Str(grouprowstart)) & ":" & Trim(Str(r - 1))).Group
                    ingroup = False
                End If
            End If
        Next r
        If ingroup Then
            .Rows(Trim(Str(grouprowstart)) & ":" & Trim(Str(maxrow))).Group
        End If
    Next i
    
End With
End Sub

If anyone can suggest why:
it is taking so long in the first place
or
why it seems to be taking longer every time I run it

I will be very grateful This is driving me absolutely nuts.

Tony

 

[N1GHTEYES]

@combo: When I was enthusing earlier, I had only seen your first post re unlinking. I see you have also answered my question about how you make the picture in code. Once again - thanks.

I'm a bit puzzled though. Perhaps you can explain something?
Is any of this available in the help, the object browser or anywhere else? Even knowing what I'm looking for I still can't find it.

In particular, where did you find the info on the range.copy method (because, as far as I can see, the help says nothing about this kind of usage), and the fact that if you create a picture when there is an image on the clipboard, it transfers the image to the picture. At least, I'm assuming that is what is happening, because I can't see anything else in the code which puts the range image onto the picture.

BTW: register?

Tony

 

[SkipVought]

register:

In assembly language proramming, you store or pack values in one of several registers, for quick use, as opposed to storing in an address in storage, where retreival access is less efficient.

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[N1GHTEYES]

Clink <--sound of penny dropping.

Ah yes, assembly language. I remember that. It's what old people talked about when I was a lad... ;-)

Tony

 

[SkipVought]

Eh, sonny? ;-)

Here's another.

Let's consider 'boot' as in boot your pc.

Any ideas where 'boot' came from? Why not simply START your pc? Eh, sonny? ;-)

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[N1GHTEYES]

As I recall, from lifting oneself by one's own bootstraps. Of course, that was back in the days when being all down to silicon meant "the stone age".

Actually, I was around back in the days of assembler and machine code, I just wasn't involved. I thought doing physics was hard enough without all this computer lark.

Nowadays I find the hardest part is just getting up in the morning. But I am capable of appreciating a neat bit of coding. And I'm still in awe of combo's solutions - both to the real problem and to the actual question I asked. I'd love to know where he gets this stuff...

Tony

 

[SkipVought]

Well I guess yer not so much of a 'sonny' then, as I appeared 2 months after Pearl Harbor was bombed.

And, yes, I too am impressed by combo and many others here at TT.

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[combo]

In object browser:
Right-click the "Members" pane and select "Show Hidden Members". You will see, among others, the Pictures collection and Picture class. Additionally, hidden properties and metods will become available in intellisense.
In "Locals" window:
In a procedure declare variable as object, assign an object to it (Set o=Shapes("ShapeName")), add a breakpoint in next line. You will see what o is and some its properties (BTW, they can be changed manually here).

In this case, I started with Pictures.Add and there was an error pointing to missing link. Having a range copied it worked, so an additional line to do it by code.
I started to code in excel in 95 version, there were sheets everywere, form controls and various shapes with specific classes, so more or less I knew the direction.
BTW, it's funny that using excel 4 macro one still can create a userform basing on a data in a worksheet range, with controls not available in current vba (driver and folder selectors).


combo

 

[N1GHTEYES]

combo: Once again - I'm getting repetitious, but I can't help it - thankyou!

I frequently use the watch window, but I've never bothered with the locals. I can see it has some advantages. I certainly never realised until now I could use it to change values.

The hidden members was also a useful tip.

I'm still a bit wary of Excel 4 macros. I have used them in the past for stuff I could not do any other way, but I find them a bit confusing and occasionally flaky in peformance.

BTW I noticed, when checking out your suggestions, that the Shape.DrawingObject properties seem to be pretty much identical to those of a Picture object. Unfortunately, even with "show hidden members" there does not seem to be any listing for the drawingobject class (only drawingobjects, which I assume is a collection class). I had a play, trying to see if any of the stuff you did with a Picture could be done with a Shape.DrawingObject, but so far no joy. I also played with assigning Picture to DrawingObject and vice-versa. So far nothing useful came out of that. I was wondering if, for example, one could create a non-rectangular shape and somehow assign it a picture. However, as I said, no joy so far. If I ever manage to get anywhere with it, I'll post it as a curiosity.

Tony

 

[N1GHTEYES]

Skip: I can also link my birth to Hawaii. It joined the union during my first year of existence.

So, you can still call me "sonny" if you like.


Whippersnapper

 

[combo]

DrawingObjects is a collection of objects of different possible classes, similarly to Sheets collection with no specific Sheet class.
The DrawingObject is is a property that translates Shape to an old interface.
[tt]ShapeRef.DrawingObject[/tt] returns object's hidden interface, in your example picture object.
In oposite [tt]PictureRef.ShapeRange(1)[/tt] returns shape from picture object.
In the Locals window one can see a chain of translations, for a picture in DrawingObjects collection:
DrawingObjects>Item x>[Picture interface]ShapeRange>Item 1>[Shape interface]DrawingObject>[Picture interface]ShapeRange>Item 1>Shape interface]... etc

combo

 

[BobJacksonNCI]

Normally I mind my own business, but ...

This thread is Rad, Totally Awesome, Way Cool, or even ... Neat!

My apologies to Nighteyes and the moderators as I couldn't keep from ranting.

Lesson: When problem code is posted, post all of it, because surprises can occur.

Combo cannot possibly still be a "Technical User" - too savvy for that title!

Skip is one of the more useful antiques I've run across...
(offense intended)

When I started with computers in, er, 1972, bootstrap was used for what we called mainframes. Later, IBM System 3's called it IPL (Initial Program Load). I learned assembler and RPG on an IBM 360, Model 20 that had 8K of memory. (NOT a typo). And the operating system was a large deck of punched cards that we had to load. Then we loaded the compiler in punched cards followed by our source code in punched cards.

My strength turned out to be using Neat/3, the primary language used on NCR mainframes. Took me from Macomb, IL, to Alton/St Louis, Bloomington, IL, Davenport, IA, New Orleans, Hawaii, and back to Mansfield, PA until NCR no longer made computers. I would still be in Hawaii if that employer still existed - loved it there.

In Alton, I was tasked with converting bank data from 6 bit bytes to 8 bit bytes on the next generation. Had never heard of 6 bit bytes or seen that model (NCR 315) computer before. Those bytes were used for a single character or a single digit. Since memory was tight, their idea of packed data was putting three digits into two bytes and calling it a slab. (Alpha data was not packed.) Then, each digit (0-9) used 4 bits as the slab contained 12 bits ...

I'm fully retired, but spend some time learning Libre Office. Kind of a survivalist thing as it could be useful if the economy continues to struggle. Writer and Calc work pretty well and are documented. Base may work all right, but documentation and support are iffy. However, I did just find

http://www.oooforum.org/

<Rant OFF>

Happy President's Day!


HTH,
Bob

 

[combo]

Bob:
As far as I remember "TechnicalUser" was my own declaration when I first logged to this forum. I did a quick check if it is possible to change it - no way. Anyway, I am not a professional programmer and generally the "TechnicalUser" is the nearest description of the way I use ms office package including vba. So I don't plan to change it, even though I frequently use vba.


combo