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)

 

[Ruddles]

Picture this scenarioo: you have a worksheet with a Worksheet_Change event which itelf changes the worksheet. Something triggers the Worksheet_Change event so it starts to run. Whilst it's running it changes something on the worksheet, so that triggers it to run again. The first instance of the code is stacked and instance #2 starts.

Instance #2 of Worksheet_Change runs and changes something on the worksheet, so that triggers it to run again. The instance #2 of the code is stacked and instance #3 starts.

Instance #3 of Worksheet_Change runs and changes something on the worksheet, so that triggers it to run again. The instance #3 of the code is stacked and instance #4 starts.

Maybe that's what's happening in this case.

Try placing Application.EnableEvents=False at the top of Worksheet_Change and Application.EnableEvents=True at the bottom. If this is what's happening, disabling events from running whilst your event handler is active may cure the problem.

No promises though!

 

[Ruddles]

Caveat: if your code fails for any reason after executing Application.EnableEvents=False and before executing Application.EnableEvents=True, your workbook will be left in a state where events are disabled.

If this happens, go to the VBA Immediate window (Ctrl-G) and enter Application.EnableEvents=True to enable them again.

(?Application.EnableEvents will tell you wether they're enabled or not.)

 

[p45cal]

Caveat: if your code fails for any reason after executing Application.EnableEvents=False and before executing Application.EnableEvents=True, your workbook will be left in a state where events are disabled.

If this happens, go to the VBA Immediate window (Ctrl-G) and enter Application.EnableEvents=True to enable them again.

(?Application.EnableEvents will tell you wether they're enabled or not.)

I find myself increasingly using another technique to reduce the recursion, useful if you want events to remain enabled because you want other events still to be triggered (or you don't wnat to have to reset application.enableevents manually after a break):

Private Sub Worksheet_Change(ByVal Target As Range)
Static Blocked As Boolean
If Not Blocked Then
  Blocked = True

  'your code (which changes the sheet)

  Blocked = False
End If
End Sub

or:

Private Sub Worksheet_Change(ByVal Target As Range)
Static Blocked As Boolean
If Blocked Then Exit Sub
Blocked = True

'your code (which changes the sheet)

Blocked = False
End Sub

 

[charleymax]

No still getting the issue.... I'm probably just going to have to co with a countIF and if the value is greater than 1 it will force the user to do a ctrl-F or filter the Doc # column to see the projects...

If anyone what's to have a last crack at it ... this is what I have.

Private Sub Worksheet_Change(ByVal Target As Range)
Static Blocked As Boolean
If Blocked Then Exit Sub
Blocked = True

''''' my code
Dim Rng As Range, Dn As Range
Dim n As Long
Dim Q, K
Dim R As Range
Set Rng = Range(Range("J2:J2500"), 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 my code

Blocked = False
End Sub

The debug breaks at

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

 

[p45cal]

I think it's very likely that there is some recursion going on somewhere. Try stepping through the macro by putting a break on the Private Sub line and pressing F8 repeatedly after making a change on the worksheet, and follow its route through the code.

 

[Simon Lloyd]

You could use this or something like it:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rFound As Range
On Error Resume Next
    Set rFound = Range("J" & Target.Row & ":J" & Range("J" & Rows.Count).End(xlUp).Row).Find(What:=ActiveCell.Value, _
    After:=Target, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    Target.Offset(0, -8) = Target.Offset(0, -5).Value & " - " & rFound.Offset(-1, 0).Value
End Sub

Just enter your change in column J and the entry in column B should be that of Column E and your entry.

 

[charleymax]

P45Cal and Simon,

OK I have the whole thing in a doubleclick now....
still seems to break down at

[COLOR=#000080]Set[/COLOR] Rng = Range(.Item(K)(2))

Simon, Your solution above only combines Doc# and Proj #... I need it to list every Proj number that that Document repeats against...


[/CODE]

Private [COLOR=navy]Sub[/COLOR] Worksheet_BeforeDoubleClick(ByVal Target [COLOR=navy]As[/COLOR] Range, Cancel [COLOR=navy]As[/COLOR] Boolean)
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] n [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] Q, K
[COLOR=navy]Dim[/COLOR] R [COLOR=navy]As[/COLOR] Range
[COLOR=navy]If[/COLOR] Target.Address(0, 0) = "A1" [COLOR=navy]Then[/COLOR]
[COLOR=navy]Set[/COLOR] Rng = Range(Range("J2"), Range("J" & rows.Count).End(xlUp))
    ReDim ray(1 To Rng.Count, 1 To 2)
        [COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
            .CompareMode = vbTextCompare
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
        [COLOR=navy]If[/COLOR] Not .Exists(Dn.value) [COLOR=navy]Then[/COLOR]
            n = n + 1
            .Add Dn.value, Array(n, Dn.Offset(, -5), Dn.Offset(, -8).Address)
        [COLOR=navy]Else[/COLOR]
            Q = .Item(Dn.value)
            Q(1) = Q(1) & ", " & Dn.Offset(, -5)
            Q(2) = Q(2) & ", " & Dn.Offset(, -8).Address
            .Item(Dn.value) = Q
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR]
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
[COLOR=navy]Set[/COLOR] Rng = Range(.Item(K)(2))
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] R [COLOR=navy]In[/COLOR] Rng
        R = IIf(InStr(.Item(K)(1), ",") > 0, .Item(K)(1), "None")
    [COLOR=navy]Next[/COLOR] R
[COLOR=navy]Next[/COLOR] K
[COLOR=navy]End[/COLOR] With
[COLOR=navy]End[/COLOR] [COLOR=navy]If[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

 

[p45cal]

I've tried your code, and without anything to stop recursion it goes into a never ending loop. Adding Ruddles' suggestions (Application.EnableEvents = False and
Application.EnableEvents = True) in msg#11 seemed to make it work as intended.

However, while stepping through the code myself I noticed that this line:
.Add Dn.Value, Array(n, Dn.Offset(, -5), Dn.Offset(, -8).Address)
the bit highlighted in red is a range, not the text in that range.

Later, if there are duplicates, you do this:
Q = .Item(Dn.Value)
which results in
Q(0) being a Long
Q(1) being a range
Q(2) being a string

The very next line you have:
Q(1) = Q(1) & ", " & Dn.Offset(, -5)
which might, with Q(1) being a range, try to change the value on the sheet as well. It didn't on mine, and after the execution of this last line, Q(1) was a string, however, I'm using Excel 2010 and you may not be.

So to remove any ambiguity, perhaps change the line:
.Add Dn.Value, Array(n, Dn.Offset(, -5), Dn.Offset(, -8).Address)
to
.Add Dn.Value, Array(n, Dn.Offset(, -5).Value, Dn.Offset(, -8).Address)
so that there are never any range objects in the dictionary, only strings.

 

[Simon Lloyd]

Not tested but try this:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rFound As Range, msg As String
On Error Resume Next
    Set rFound = Range("J" & Target.Row & ":J" & Range("J" & Rows.Count).End(xlUp).Row).Find(What:=ActiveCell.Value, _
    After:=Target, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    If Not rFound Is Nothing Then
strFirst = rFound.Address
Do
msg = msg & rFound.Offset(0, -5).Value & ","
Set rng = Range("J" & Target.Row & ":J" & Range("J" & Rows.Count).End(xlUp).Row).FindNext(rFound)
Loop Until rFound.Address = strFirst
    Target.Offset(0, -8) = msg
End Sub