Copy unique values problem


B

bojan0810

Hi all

Sub Rectangle1_Click()
CopyUniques Sheets("sheet1").Range("a2:a1000"), Sheets("Pick List").Range("a2")
End Sub
Sub CopyUniques(rngCopyFrom As Range, rngCopyTo As Range)
Dim d As Object, c As Range, k
Set d = CreateObject("scripting.dictionary")
For Each c In rngCopyFrom
If Len(c.Value) > 0 Then
If Not d.Exists(c.Value) Then d.Add c.Value, 1
End If
Next c
k = d.keys
rngCopyTo.Resize(UBound(k) + 1, 1).Value = Application.Transpose(k)
End Sub


I have this macro in button, but that isnt problem.

So it copies unique value from one sheet to another. Works great, but it has one problem.

If I delete one value in sheet 1, it doesnt remove that value in Pick List sheet.

For example
a
a
b
c
c

And when macro do his it will be like this
a
b
c

But If I remove for example last c in first sheet it stays
a
b
c
c

I want to make something like overwrite macro or something like that, so it doesnt leave like that

Thank you
 
Ad

Advertisements

C

Claus Busch

Hi,

Am Thu, 17 Apr 2014 01:35:04 -0700 (PDT) schrieb (e-mail address removed):
If I delete one value in sheet 1, it doesnt remove that value in Pick List sheet.
try following code in the code module of Sheet1:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A2:A1000")) Is Nothing Or _
Target.Count > 1 Then Exit Sub

Dim myDic As Object
Dim arrIn As Variant
Dim arrOut As Variant
Dim i As Long

arrIn = Range("A2:A1000")
Set myDic = CreateObject("Scripting.Dictionary")

For i = LBound(arrIn) To UBound(arrIn)
myDic(arrIn(i, 1)) = arrIn(i, 1)
Next

arrOut = myDic.items

With Sheets("Pick List")
.Range("A:A").ClearContents
.Range("A2").Resize(rowsize:=myDic.Count) = _
WorksheetFunction.Transpose(arrOut)
End With

End Sub


Regards
Claus B.
 
B

bojan0810

Dana Äetvrtak, 17. travnja 2014. 10:49:27 UTC+2, korisnik Claus Busch napisao je:
Hi,



Am Thu, 17 Apr 2014 01:35:04 -0700 (PDT) schrieb (e-mail address removed):






try following code in the code module of Sheet1:



Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, Range("A2:A1000")) Is Nothing Or _

Target.Count > 1 Then Exit Sub



Dim myDic As Object

Dim arrIn As Variant

Dim arrOut As Variant

Dim i As Long



arrIn = Range("A2:A1000")

Set myDic = CreateObject("Scripting.Dictionary")



For i = LBound(arrIn) To UBound(arrIn)

myDic(arrIn(i, 1)) = arrIn(i, 1)

Next



arrOut = myDic.items



With Sheets("Pick List")

.Range("A:A").ClearContents

.Range("A2").Resize(rowsize:=myDic.Count) = _

WorksheetFunction.Transpose(arrOut)

End With



End Sub





Regards

Claus B.

--

Vista Ultimate / Windows7

Office 2007 Ultimate / 2010 Professional
Thanks for reply, but it is still acting same. I tried to add a b c to column A and deleted c, and on Pick List c was there still
 
C

Claus Busch

Hi,

Am Thu, 17 Apr 2014 03:08:55 -0700 (PDT) schrieb (e-mail address removed):
Thanks for reply, but it is still acting same. I tried to add a b c to column A and deleted c, and on Pick List c was there still
no, that couldn't be because the data in Pick List will first be deleted
and the unique values are new written. If you add a new value or if you
delete a value the code writes always a new unique list.


Regards
Claus B.
 
C

Claus Busch

Ad

Advertisements

B

bojan0810

Dana Äetvrtak, 17. travnja 2014. 12:49:48 UTC+2, korisnik Claus Busch napisao je:
Hi,



Am Thu, 17 Apr 2014 03:08:55 -0700 (PDT) schrieb (e-mail address removed):






look here:

https://onedrive.live.com/?cid=9378AAB6121822A3&id=9378AAB6121822A3!326#cid=9378AAB6121822A3&id=9378AAB6121822A3!326

for "PickList" and rightclick and download the file because marcros are

disabled in OneDrive.





Regards

Claus B.

--

Vista Ultimate / Windows7

Office 2007 Ultimate / 2010 Professional
That is weird. I downloaded yours and it is working ok. On my file it isnt working like that. Maybe I did something wrong and didnt noticed.

Anyway, thank you alot... I have lot of files similar to that one and it will help me alot and it will be much easier now.

Thanks
 
Ad

Advertisements


Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

copy range of unique value 1
Unique Values 2
Counting unique values 3
unique values in Excel 4
VBA for unique values 11
Unique Values in a List 2
Counting unique values 6
Counting Unique Values 6

Top