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

 

[SkipVought]

hi,

Just a shot in the dark, but try switching the order of occurrence of code for deleting hyperlinks and cells.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[SkipVought]

...that is within textsheet.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[SkipVought]

also [highlight]now [/highlight]is a VB Function that returns Date/Time. It's not a particularly good practice to use VB function names as variables. Don't know if that could have a degrading effect though.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[Andrzejek]

If it takes longer and longer to do the same stuff, I usually look for something that gets filled and does not get empty at the end.

First, I would use Option Explicit
Second, I would NOT use what could be 'reserved words', like: now, report, start, name, select, case, etc.
Third, I would take a closer look at:
[tt]
ReDim namelist(1 To numshapes) As Variant
ReDim MyNames(1 To numshapes) As Variant
...
ReDim Preserve MyNames(1 To namecount) As Variant
ReDim Preserve namelist(1 To namecount) As Variant
[/tt]
I usually do:
[tt]
Dim SomeVar() As Something
...
ReDim SomeVar(X to Y)
[/tt]
When you ReDim, you create a copy of your array. The more copies you create, the more memory you use. I would empty the arrays at the end.

Just a guess here...

Have fun.

---- Andy

 

[N1GHTEYES]

Thanks for looking at this folks.

Re order of deleting hyperlinks and cells:
Actually, I originally had it the other way round. This way is faster.

Re now, report:
OK, I changed now to nw instead and report to rpt. No difference.

Re Option explicit:
I added it, but it threw up no errors, so I guess I was dimming everything anyway. No change to times.

Re dimming Vs redimming: I added explicit dims but no change to times. Also, I would not have expected any, because I time what happens at various parts of the sub and the slow bits don't start until after the dimming / redimming anyway.

Interestingly, I'd like to clarify something in my first post. Saving, closing and re-opening the workbook does NOT restore the time taken to its original value. Closing Excel does.

Tony

 

[SkipVought]

This would only affect run time. Declare any variable with the MINIMUM data size possible.

loop counters ought to be Integer, rather than Long, unless the loop count could exceed 32767.

Your name arrays are declared as Variant. Could they be declared as String? Also, NEITHER are used for anyting in the code you posted???

Also you have undeclared variables and Option Explicit -- COMPILE results in many UNDECLARED!



Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[N1GHTEYES]

Skip: I'm at home now, so working from memory. However, to answer your points as best I can...

I normally use longs in preference to integers, becasue I read ages ago that on a 32 bit machine, longs are actually faster. I could easily change these to integer, but I'd be surprised if that could significantly affect such very long runtimes.

The namelist array is declared as variant because the elements actually contain 3-item arrays. If I remember correctly the items are:
a collection of all the "down" connectors from this shape,
the number of down connectors from this shape
and
the "depth" of the shape in the tree.

That might seem a tad messy, but it seems to work The macro does do what it is meant to do. It is just stupidly slow. However, the whole process of creating these arrays takes place in the very quick portion of the macro. The two stages which go slowly come well after the Get_Leg sub in which these arrays are created.

As for the "undeclared" vars, they are not undeclared, they are (ducks head in shame) global vars and are declared at module level. Not good practice I know, but it was the only way I could achieve the functionality I needed. I tried to think of a way of passing them as arguments, but the problem is that the process by which the arrays are created is recursive, and passing the arguments recursively made it impossible to access the arrays in the way I needed to to build them properly, because different branches of the tree were accessing different versions of the array when I needed them to acces a single version of a common array.

However, I'd again point out that all the stuff involving these arrays takes place before the slow part of the macro. Also, I tried commenting out the lines in which the macro: actually populates the cells in KCtext, creates the hyperlinks and does the grouping/outline procs. It was still accessing the namelist array. The time went down to ~<1s. So I don't think that the arrays are the problem. The three items which seem to take the time are:

writing the values to the cells and colouring them
creating the hyperlinks
creating the group outlines.

I'm afraid the above might be a bit woolly & unclear, but, as I said, I'm working from memory here. Sorry.


Tony

 

[N1GHTEYES]

Skip: I did not originally include all the code because I thought the parts I left out were irrelevant and I did not want to have to make anyone wade through reams of code which had no bearing on the problem.

However, I might be mistaken in figuring out what is relevant and you've made reference to the rest, so here it is in case it helps.

This is called recursively to populate namelist(). It also populates MyNames(), but that is used in some completely separate code which certainly has no part in this issue.

Sub Get_Leg(thisshape As Shape, ByVal c As Long)
On Error Resume Next
    c = c + 1
    
    Dim con As Variant
    Dim i As Long
    Dim dependentshape As Shape
    namecount = namecount + 1
    MyNames(namecount) = thisshape.name
    namelist(namecount) = Array(thisshape.name, namecount, c)
    For i = 1 To shpconlist.Item(thisshape.name).down.Count
        con = shpconlist.Item(thisshape.name).down(i)
        namecount = namecount + 1
        If namecount + 10 >= UBound(MyNames) Then
            ReDim Preserve MyNames(1 To namecount + 100) As Variant
            ReDim Preserve namelist(1 To namecount + 100) As Variant
        End If
        MyNames(namecount) = con
        namelist(namecount) = Array(con, namecount, c)
        Set dependentshape = ActiveSheet.Shapes(con).ConnectorFormat.EndConnectedShape
        Get_Leg dependentshape, c
        Err.Clear
    Next i
Err.Clear

End Sub

The following is used to create a collection of ShapeCon objects which list how each shape is connected up- and down-stream.

Public Sub CreateConnectorList()
On Error Resume Next
Dim wksht As Worksheet
Set wksht = Worksheets("Kids Cascade")
Dim shp As Shape
Set shpconlist = New ShapeConnections
For Each shp In wksht.Shapes
    If shp.connector Then
        If shp.ConnectorFormat.BeginConnected Then
            shpconlist.Add shp.ConnectorFormat.BeginConnectedShape.name, shp.name, True
        End If
        If shp.ConnectorFormat.EndConnected Then
            shpconlist.Add shp.ConnectorFormat.EndConnectedShape.name, shp.name, False
        End If
    End If
Next shp
Err.Clear

End Sub

This is the code for the ShapeConnections which is a collection class for ShapeCon objects.

Private mycol As Collection
Private Sub Class_Initialize()
Set mycol = New Collection
End Sub

Public Sub Add(shapename As String, connectorname As String, down As Boolean)
On Error Resume Next
'This process adds a new connector to the down collection or up collection for item mycol(shapename) (depending on the value of "down")

Dim thiscon As ShapeCon
Set thiscon = mycol(shapename)
If Err.Number <> 0 Then
    Err.Clear
    Set thiscon = New ShapeCon
    thiscon.name = shapename
    mycol.Add Item:=thiscon, key:=shapename
End If
If down Then
    mycol(shapename).down.Add Item:=connectorname, key:=connectorname
Else
    mycol(shapename).up.Add Item:=connectorname, key:=connectorname
End If
'Set mycol(shapename) = thiscon
Err.Clear

End Sub
Public Property Get Item(shapename As Variant) As ShapeCon
Set Item = mycol(shapename)
End Property

Public Property Get Count() As Long
 Count = mycol.Count
End Property

And here is the code for the shapeCon class itself.

Public down As Collection
Public up As Collection
Public name As String
Private Sub Class_Initialize()
Set down = New Collection
Set up = New Collection
End Sub

I hope that makes things a bit clearer.

Tont

 

[SkipVought]

I see several SETS without corresponding NOTHING. If these are called recursively.....

You might also look at instances in your code like this...

dim obj as SomeObject

set obj = SomeObjectInstance

with obj

end with

or

dim obj as SomeObject

set obj = SomeObjectInstance

for each oj in obj.ojs

next
end with

Why declare an object variable when you use it but one time, or by simple reference? Rather something like this...

With SomeObjectInstance

  for each oj in .ojs

  next
End with

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[xlbo]

I don't have much time to look at this but as a general concept if something is aking longer each time than it did previosuly with no change in data volumes then there isa mmory leak issue - this I would think would be confirmed by the fact that it resets itself when you close excel

Memory leaks can be a right royal pain to trap but as Skip has mentioned, a common cause is not releasing objects after setting them

Rgds, Geoff

We could learn a lot from crayons. Some are sharp, some are pretty and some are dull. Some have weird names and all are different colours but they all live in the same box.

Please read FAQ222-2244 before you ask a question

 

[N1GHTEYES]

Skip, Geoff: Thanks for the comments. By taking note of some of Skip's suggestions, and by spotting other errors whilst I was doing so, I managed to get the minimum execution time down from ~30s with a fresh sheet, down to ~10s.

However, I have now discovered the real problem. It was something I had not mentioned until now because it had not occurred to me that it could be related. I have a "camera" picture object on the Kids Cascade sheet. The purpose is to allow the user to have a zoomed view of any selected cells while still viewing the whole diagram in a "zoomed-out" manner. If I delete this camera object, the execution time goes down to <=0.5s.

Even if I have a camera object with a different name (so it is not called by any of my code and cannot possibly play a direct role in what the code is doing), the execution time is still the same. It seems the very presence of the picture object screws the execution time. It also takes longer every time it runs when the camera picture object is there.

I have tried making the picture object invisible, I have commented out any lines which refer to it, I have even changed the code so that the instant it starts running it switches to viewing the KCtext sheet (so the camera object is not displayed during execution). None of these make any difference. If there is a camera / picture object anywhere in the workbook, the execution time increases from .5s to 10s, and the time starts to increase every time it is run.

OK, so now what I want to do is delete the picture object at the start of the sub, then re-creat it at the end.

The problem is, I don't know exactly what a camera / picture onject is. I tried recording a macro when I create one, but if I'm recording a macro, the camera tool does not seem to work.

I also recorded a macro when moving an existing picture object, and changing its target address. That allowed me to figure out where the picture was "pointed" and how to change that parameter, but I could not find out from browsing the "watched" picture object exactly what type it was.

So the killer question boils down to this: Does anyone know how to create a picture object on a workbook in code (as if I'd clicked the camera button)? If so, any hints will be VERY gratefully received.

Tony

 

[combo]

A camera is an old Picture object (replaced by Shape), with interface hidden in vba. Assuming that it is named picCamera, you can temporarily unlink it:

Dim objCamera As Picture
Set objCamera = ActiveSheet.Pictures("picCamera")
objCamera.Formula = ""
' run the slow loop
objCamera.Formula = "A1:D4"

combo

 

[SkipVought]

Great tip combo!

You might also consider changing Calculation to MANUAL and explicitly calculate ranges or sheets and/or the application at appripriate point(s) in your code.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[combo]

Thanks Skip.
I found that one can add picture programmatically having a range copied:

Dim objCamera As Picture
With ThisWorkbook
    .Worksheets(2).Range("TestRange").Copy
    With .Worksheets(1).Pictures.Add(20, 20, 100, 100)
        .Name = "picCamera"
        .TopLeftCell = Arkusz1.Range("B2")
    End With
End With

combo

 

[combo]

Sorry for typo in the code above, should be:

Dim objCamera As Picture
With ThisWorkbook
    .Worksheets(2).Range("TestRange").Copy
    With .Worksheets(1).Pictures.Add(20, 20, 100, 100)
        .Name = "picCamera"
        .TopLeftCell = ThisWorkbook.Worksheets(1).Range("B2")
    End With
End With

combo

 

[N1GHTEYES]

Combo: I hereby officially bow down and worship you!! ===> *

I have been struggling with this, on and off, for days. I tried everything I could think of to make it run at a sensible speed with the picture object present and/or delete and re-create it. The idea of "unlinking" it just did not occur to me.

I've modded it as you suggested and now the whole thing works fine, i.e. I still get to use my magnified view and I can transcribe the entire diagram hierarchy to a mutually hyperlinked text list in <0.5s. Woo Hoo!!

Thanks again. Brilliant.

Tony

 

[N1GHTEYES]

BTW Skip, I had already tried everything else I could think of, including setting calculation to manual and screenupdating to false. But thanks for the suggestion.

Tony

 

[SkipVought]

@combo: That's one to pack in a register! ;-)

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[combo]

Hi Skip,
I did it, however I can bet that your register is much longer !

combo