Run time error simplification of VBA needed I think?

[charleymax]

Hi all,

I have the below that was modified from code kindly created by MikeG...
I'm having trouble though as I'm trying to run in in a worksheet with 1500 rows and I end up with the following error message:

Run time error 1004
out of stack space

Anyone know what I'm doing wrong.. Perhaps I just need ot to update for any rows with the same Doc # as the one I just updated... But I think every time I change 1 cell it re checks the entire sheet...

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Dn As Range
Dim n As Long
Dim Q, K
Dim R As Range
Set Rng = Range(Range("J2"), Range("j" & Rows.Count).End(xlUp))
    ReDim ray(1 To Rng.Count, 1 To 2)
        With CreateObject("scripting.dictionary")
            .CompareMode = vbTextCompare
    For Each Dn In Rng
        If Not .Exists(Dn.Value) Then
            n = n + 1
            .Add Dn.Value, Array(n, Dn.Offset(, -5), Dn.Offset(, -8).Address)
        Else
            Q = .Item(Dn.Value)
            Q(1) = Q(1) & ", " & Dn.Offset(, -5)
            Q(2) = Q(2) & ", " & Dn.Offset(, -8).Address
            .Item(Dn.Value) = Q
        End If
    Next
For Each K In .keys
Set Rng = Range(.Item(K)(2))
    For Each R In Rng
        R = IIf(InStr(.Item(K)(1), ",") > 1, .Item(K)(1), "None")
    Next R
Next K
End With
End Sub

Just to clarify this is designed to update the above sheet so that anytime I update a Doc # in col J Col B (Crossover) is updated with any project names from Col E that contain that Doc number... As I stated my code running on worksheet_change is I think rechecking & updating everything everytime I update... I might want to simplify and only update rows where Doc # matches the cells I updated any maybe only do the update on save or on close.... Can anyone advise... (reason for edit to add this paragraph to clarify)

 

[Simon Lloyd]

Why not add Application.Calculation = xlManual at the begining of your code (after any Dim's) and Application.Calculation = xlAutomatic at the end of your code (before end sub)

 

[charleymax]

Why not add Application.Calculation = xlManual at the begining of your code (after any Dim's) and Application.Calculation = xlAutomatic at the end of your code (before end sub)

Hi Simon,

No doesn't help...

Code now looks like this:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim icolor As Integer
    If Not Intersect(Target, Range("M2:M5000")) Is Nothing Then
        Select Case Target
            
            Case "Approved"
                icolor = 35
            
            Case "Closed"
                icolor = 37
            Case "Routing"
                icolor = 3
            Case "Edit"
                icolor = 41
            Case "Cancelled"
                icolor = 15
                
            Case "Project On hold"
                icolor = 13
            Case "WIP"
                icolor = 4
            
            Case "Draft"
                icolor = 38
            
            Case Else
                'Whatever
        End Select
     
        Target.EntireRow.Interior.ColorIndex = icolor
    End If
Dim Rng As Range, Dn As Range
Dim n As Long
Dim Q, K
Dim R As Range
Application.Calculation = xlManual
Set Rng = Range(Range("J2"), Range("j" & Rows.Count).End(xlUp))
    ReDim ray(1 To Rng.Count, 1 To 2)
        With CreateObject("scripting.dictionary")
            .CompareMode = vbTextCompare
    For Each Dn In Rng
        If Not .Exists(Dn.Value) Then
            n = n + 1
            .Add Dn.Value, Array(n, Dn.Offset(, -5), Dn.Offset(, -8).Address)
        Else
            Q = .Item(Dn.Value)
            Q(1) = Q(1) & ", " & Dn.Offset(, -5)
            Q(2) = Q(2) & ", " & Dn.Offset(, -8).Address
            .Item(Dn.Value) = Q
        End If
    Next
For Each K In .keys
Set Rng = Range(.Item(K)(2))
    For Each R In Rng
        R = IIf(InStr(.Item(K)(1), ",") > 1, .Item(K)(1), "None")
    Next R
Next K
Application.Calculation = xlAutomatic
End With
End Sub

I get the same -
Run time error 1004
out of stack space

 

[Simon Lloyd]

Try this see how you go

Private Sub Worksheet_Change(ByVal Target As Range)
Dim icolor As Integer
Dim Rng As Range, Dn As Range
Dim n As Long
Dim Q, K
Dim R As Range
Application.Calculation = xlManual
   If Not Intersect(Target, Range("M2:M" & Range("M" & Rows.Count).End(xlUp).Row)) Is Nothing Then
Select Case Target
            
            Case "Approved"
                icolor = 35
            
            Case "Closed"
                icolor = 37
            Case "Routing"
                icolor = 3
            Case "Edit"
                icolor = 41
            Case "Cancelled"
                icolor = 15
                
            Case "Project On hold"
                icolor = 13
            Case "WIP"
                icolor = 4
            
            Case "Draft"
                icolor = 38
            
            Case Else
                'Whatever
        End Select
     
        Target.EntireRow.Interior.ColorIndex = icolor
    End If

Set Rng = Range(Range("J2"), Range("j" & Rows.Count).End(xlUp))
    ReDim ray(1 To Rng.Count, 1 To 2)
        With CreateObject("scripting.dictionary")
            .CompareMode = vbTextCompare
    For Each Dn In Rng
        If Not .Exists(Dn.Value) Then
            n = n + 1
            .Add Dn.Value, Array(n, Dn.Offset(, -5), Dn.Offset(, -8).Address)
        Else
            Q = .Item(Dn.Value)
            Q(1) = Q(1) & ", " & Dn.Offset(, -5)
            Q(2) = Q(2) & ", " & Dn.Offset(, -8).Address
            .Item(Dn.Value) = Q
        End If
    Next
For Each K In .keys
Set Rng = Range(.Item(K)(2))
    For Each R In Rng
        R = IIf(InStr(.Item(K)(1), ",") > 1, .Item(K)(1), "None")
    Next R
Next K
Application.Calculation = xlAutomatic
End With
End Sub

 

[charleymax]

Hi Simon,

Thanks for looking at this for me....
No still getting the stack error

When I hit the debug button it seems to have hanged on..

Set Rng = Range(.Item(K)(2))

 

[Simon Lloyd]

What exactly are you trying to do with all that looping?

 

[charleymax]

Just to clarify this is designed to update the above sheet so that anytime I update a Doc # in col J, Col B (Crossover) is updated with any project names from Col E that contain that Doc number...

So... say I now change the first row above so that Doc type changes from 123456 to 4P53L-01 then cell B1 would update to show "TBD, 10-18957" because 4P53L-01 would then be listed against both these projects.

The idea is that a document author when logging a new change can see if there are any others queued and then coordinate so that the 2 project updates can be done together thus reducing workload...

My code running on worksheet_change is I think rechecking & updating everything everytime I update ANYTHING... I might want to simplify and only update rows where Doc # matches the cells I updated any maybe only do the update on save or on close.... Can anyone advise... (reason for edit to add this paragraph to clarify)[/QUOTE]

 

[Ruddles]

Are you changing the sheet inside its own Worksheet_Change procedure? I mean the values in the sheet - colours don't count.

 

[sous2817]

Check your locals, what's the value of K?

I don't think the syntax of:

Set Rng = Range(.Item(K)(2))

is correct (just a stab, but check to make sure K is returning the expected value and that you can in fact set it to Range as you're trying).

 

[charleymax]

Are you changing the sheet inside its own Worksheet_Change procedure? I mean the values in the sheet - colours don't count.

Yes I am...!

I take it you've struch on the issue. Do I need to change to Worksheet_SelectionChange or something...

Sorry Ruddles, I'm a wee bit of a luddite with this as I'm kinda selft taught trial an error stuff...

Would very much appreciate your assistance in getting this sorted. does Worksheet_SelectionChange allow me to only update the worksheet if a particular selection is updated and if so can I keep from getting into this never ending loop...

this is the original thread where I asked for the solution....
http://www.mrexcel.com/forum/showthread.php?t=533293