Lijst met unieke waarde

[matthijsdekker]

Beste Allemaal,

Ik ben bezig met een bestandje te maken waarin het volgende aan de hand is.
Ik heb een kolom met allemaal namen dit kunnen aantal keer dezelfde namen zijn of namen die maar een keer voor komen. Doormiddel van een macro, zie hieronder, kan ik een lijst maken van de unieke waarde.

Sub Unieke()
For Each cl In Sheets("blad1").Range("A:A").SpecialCells(2)
If cl.Row <> 1 Then
If InStr(c01, cl.Value) = 0 Then c01 = c01 & "|" & cl.Value
End If
Next
Sheets("blad2").Range("A1").Resize(UBound(Split(c01, "|")) + 1, 1).Value = WorksheetFunction.Transpose(Split(c01, "|"))
End Sub

Wat ik nu nog wil toevoegenn deze macro is hoe vaak een unieke waarde voorkomt in die kolom. Dit moet in een nieuwe kolom komen te staan.
Het eind resultaat moet dus worden
piet 4
anja 2
etc..

alvast bedankt

Matthijs

 

[HSV]

Laat de code maar een lopen.

Sub hsv()
Dim sn, i As Long
sn = Blad1.Cells(1).CurrentRegion
With CreateObject("scripting.dictionary")
  For i = 1 To UBound(sn)
    .Item(sn(i, 1)) = .Item(sn(i, 1)) + 1
  Next i
 Blad2.Cells(1).Resize(.Count, 2) = Application.Transpose(Array(.keys, .items))
End With
End Sub

 

[matthijsdekker]

Bedankt voor de snelle reactie. hij werkt gedeeltelijk. In mijn bestandje moeten de gegevens gehaald worden uit kolom D. Met het bovenstaand krijg ik dat niet voor elkaar elke keer pakt hij weer de eerste kolom. wat doe ik fout?

 

[HSV]

Waarschijnlijk....

.Item(sn(i, [COLOR=#FF0000]4[/COLOR])) = .Item(sn(i, [COLOR=#FF0000]4[/COLOR])) + 1

...maar ik ben niet helderziend.

 

[matthijsdekker]

De aanpassing zelf is goed als ik hier 2 of 3 invoer dan pakt hij de gegevens uit kolom b en c echter wanneer ik 4 invul voor kolom D krijg ik een scherm valt buiten bereik

 

[E v R]

Draaitabel is geen optie....?

 

[matthijsdekker]

die manier kan ook inderdaad dankje!!

 

[HSV]

Dan is er geen aaneengesloten bereik vanaf A1.
Ik verwachte een Excel bestandje daar ik schreef dat ik niet helderziend ben.

Sub hsv()
Dim sn, i As Long
sn = Blad1.Columns(4).SpecialCells(2)
With CreateObject("scripting.dictionary")
  For i = 1 To UBound(sn)
    .Item(sn(i, 1)) = .Item(sn(i, 1)) + 1
  Next i
 Blad2.Cells(1).Resize(.Count, 2) = Application.Transpose(Array(.keys, .items))
End With
End Sub

Maar prima als je met een draaitabel geholpen bent.