Copying unique value in a column named range to a range in same worksheet in worksheet change event

anshulgupta28 · May 16th 2020

Hello Expert,

I am trying to copy the unique value from a dynamic named range to a range in a worksheet using advancedfilter method every time when value is changed or new data in added to named range. I am facing two problems.

Every time when new data is entered in named range : 'Test', it gives me runtime error i.e. runtime error28 : Out of stack space
In filtered result, I want to copy a sum of data corresponding to unique value of named range 'Test' present in column 'Price' of the table as shown in attached workbook. Any lead to achieve it would be helpful.

Please help me resolve this error, and achieve above functionality. Thanks in advance

Code

Private Sub Worksheet_Change(ByVal Target As Range)

Dim cellValue As Variant
Dim coll As New Collection
Dim count As Long

'-----------Counting No. of unique values in named range :'test'-----------------------
Set Target = Range("test")

On Error Resume Next

For Each cellValue In Target.Value

coll.Add cellValue, CStr(cellValue)

Next

count = coll.count

Sheet1.Range("k2") = count

'----------------copying unique values to a range-------------------
Target.AdvancedFilter Action:=xlFilterCopy, copytorange:=Sheet1.Range("K7"), unique:=True

End Sub

Display More

Logit · May 16th 2020

Your code specifies a Range named "Test"

Set Target = Range("test")

However, the range does not appear to exist. So Excel, in trying to utilize that range, max's itself out.

Fluff13 · May 16th 2020

You are changing the sheet within the change event. This will cause the event to run again, which then changes the sheet & runs the code again.

In other words, you have created a permanent loop.

You need to stop events from running like

Code

Application.EnableEvents = False
Sheet1.Range("k2") = count

'----------------copying unique values to a range-------------------
Target.AdvancedFilter Action:=xlFilterCopy, copytorange:=Sheet1.Range("K7"), unique:=True
Application.EnableEvents = True

Also you should never use VBA keywords such as Target for your own variables.

anshulgupta28 · May 17th 2020

Thanks for your reply. It's working fine now.

But I have a problem in advanced filter. It is copying duplicated data from named range. I see that 1st row data of named range "test" is compulsorily getting copied as shown in below workbook. Please help.

Also, I would like to add the 'Price' column for all unique value in code column and display it in filtered range. How do I do that.

Fluff13 · May 17th 2020

Do you want to sum the price for duplicated items?

anshulgupta28 · May 17th 2020

Yes. Also advanced filter is not working properly. Help me resolve it too.

Fluff13 · May 17th 2020

Ok, how about

Code

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Cl As Range

'-----------Counting No. of unique values in named range :'test'-----------------------
With CreateObject("scripting.dictionary")
   For Each Cl In Range("test")
      .Item(Cl.Value) = .Item(Cl.Value) + Cl.Offset(, 3).Value
   Next Cl

   Application.EnableEvents = False
   Sheet1.Range("k2") = .Count
   Sheet1.Range("K7").Resize(.Count, 2).Value = Application.Transpose(Array(.keys, .items))

   Application.EnableEvents = True
End With

End Sub

Display More

anshulgupta28 · May 17th 2020

It works perfectly fine. It would be great if you can tell me logic behind this code.

Fluff13 · May 17th 2020

Whilst you were using a collection just to count the number of unique values, I used a dictionary to store those numbers & add the price, then printed out the dictionary at the end.

For more info on dictionaries have a look here

https://excelmacromastery.com/vba-dictionary/

anshulgupta28 · May 18th 2020

Thank you so much Fuff13 for introducing me to this concept. Very helpful.

There is one doubt I would like to clear, I get an error: "Runtime Error '1004' : Method 'Range' of object '_worksheet' failed." whenever there is no value in the named range and I try to enter first value. Please let me know how I can resolve such error. Is there any error handling method for it!

Fluff13 · May 18th 2020

How about

Code

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Cl As Range, Rng As Range

On Error Resume Next
Set Rng = Range("test")
On Error GoTo 0
If Rng Is Nothing Then Exit Sub
'-----------Counting No. of unique values in named range :'test'-----------------------
With CreateObject("scripting.dictionary")

   For Each Cl In Range("test")
      .Item(Cl.Value) = .Item(Cl.Value) + Cl.Offset(, 3).Value
   Next Cl

   Application.EnableEvents = False
   Sheet1.Range("k2") = .Count
   Sheet1.Range("K7:l" & Rows.Count).ClearContents
   Sheet1.Range("K7").Resize(.Count, 2).Value = Application.Transpose(Array(.keys, .items))

   Application.EnableEvents = True
End With

End Sub

Display More

anshulgupta28 · May 21st 2020

Thank you so much. How can we restrict the worksheet_change to run only when 'code' and 'price' column value changes.

I tried putting if statement in line 2 like

Code

Private Sub Worksheet_Change(ByVal Target As Range)
if target <> range("test") or target <> range("test").offset(,3) then exit sub
Dim Cl As Range, Rng As Range
On Error Resume Next
Set Rng = Range("test")
On Error GoTo 0
If Rng Is Nothing Then Exit Sub
'-----------Counting No. of unique values in named range :'test'-----------------------
With CreateObject("scripting.dictionary")
 For Each Cl In Range("test")
 .Item(Cl.Value) = .Item(Cl.Value) + Cl.Offset(, 3).Value
 Next Cl
 Application.EnableEvents = False
 Sheet1.Range("k2") = .Count
 Sheet1.Range("K7:l" & Rows.Count).ClearContents
 Sheet1.Range("K7").Resize(.Count, 2).Value = Application.Transpose(Array(.keys, .items))
 Application.EnableEvents = True
End With
End Sub

Display More

Fluff13 · May 21st 2020

How about

Code

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim Cl As Range, Rng As Range
   If Not Intersect(Target, Range("D4:D4000,G4:G4000")) Is Nothing Then
      On Error Resume Next
      Set Rng = Range("test")
      On Error GoTo 0
      If Rng Is Nothing Then Exit Sub
      '-----------Counting No. of unique values in named range :'test'-----------------------
      With CreateObject("scripting.dictionary")
      
         For Each Cl In Range("test")
            .Item(Cl.Value) = .Item(Cl.Value) + Cl.Offset(, 3).Value
         Next Cl
      
         Application.EnableEvents = False
         Sheet1.Range("k2") = .Count
         Sheet1.Range("K7:l" & Rows.Count).ClearContents
         Sheet1.Range("K7").Resize(.Count, 2).Value = Application.Transpose(Array(.keys, .items))
      
         Application.EnableEvents = True
      End With
   End If
End Sub

Display More

anshulgupta28 · Jun 9th 2020

This is resolved. Thank you so much Fluff13

Fluff13 · Jun 9th 2020

You're welcome & thanks for the feedback.

Copying unique value in a column named range to a range in same worksheet in worksheet change event

Participate now!

Share

Tags