Copy unique values problem

[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

 

[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.

 

[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

 

[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.

 

[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

look here:
https://onedrive.live.com/?cid=9378...#cid=9378AAB6121822A3&id=9378AAB6121822A3!326
for "PickList" and rightclick and download the file because marcros are
disabled in OneDrive.


Regards
Claus 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=9378...#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