Funktion til at finde unikke værdier

Een måde er at lave en pivot tabel på din liste.

Hvis du derefter har brug for at arbejde videre med listen kan du kopiere den og indsætte den med "indsæt speciel" som værdier.

Een måde er at lave en pivot tabel på din liste.

Hvis du derefter har brug for at arbejde videre med listen kan du kopiere den og indsætte den med "indsæt speciel" som værdier.

Forudsat dine data starter i A3 og nedefter, vil følgende makro danne den sorterede liste i kolonne I :

Sub koersel()
Dim omrode As Range
Dim sort As Range
Set omrode = ActiveSheet.Range("a:a")
Set sort = ActiveSheet.Range("i:i")
For a = 3 To 60000
    If omrode(a, 1) = "" Then
    GoTo neste
    End If
        sort(a, 1) = Left(omrode(a, 1), 4)
Next
neste:
        sort.Select
        Selection.sort Key1:=Range("i:i"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
sortering:
For b = 1 To 60000
    If sort(b, 1) = "" Then
    Exit Sub
    End If
If sort(b, 1) = sort(b + 1, 1) Then
    sort(b, 1).Delete shift:=xlUp
    GoTo sortering
End If
Next
End Sub

Sub listuniq()
Dim NoDupes As New Collection
Dim strCheck As String
Dim Fra As Range, Til As Range, Cell As Range
Dim i As Long
    Set Fra = Application.InputBox("marker inputområde (een kolonne)", "Inputområde", , , , , , 8)
    Set Til = Application.InputBox("marker 1. celle i outputområde", "outputområde", , , , , , 8)
    On Error Resume Next
    For Each Cell In Fra
        NoDupes.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    Err.Clear
    On Error GoTo 0
    For Each Item In NoDupes
        Til.Offset(i, 0) = Item
        i = i + 1
    Next
    Range(Til, Til.Offset(i - 1, 0)).Sort Key1:=Til, Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub

Denne makro gør start set den samme som aheiss's, men måske lidt hurtigere.
I første box skal du marker de celler du ønsker de unikke værdier fra og i den anden markerer du første celle af outputområdet.

Ja det må siges at være en mere elegant løsning. Dog vil et valg af en hel kolonne ("A:A"), ved egentlig brug af blot 1000 rækker gøre kørslen en del mere tidskrævende en nødvendig. Men man kunne jo justere til :

Sub listuniq2()
Dim NoDupes As New Collection
Dim strCheck As String
Dim Fra As Range, Til As Range, Cell As Range
Dim i As Long
Set Fra = Application.InputBox("marker inputområde (een kolonne)", "Inputområde", , , , , , 8)
If Fra.Rows.Count = 65536 Then
  kolon = Application.WorksheetFunction.Find(":", ActiveSheet.UsedRange.Address(ReferenceStyle:=xlR1C1), 1)
  start = Application.WorksheetFunction.Find("R", ActiveSheet.UsedRange.Address(ReferenceStyle:=xlR1C1), kolon)
  slut = Application.WorksheetFunction.Find("C", ActiveSheet.UsedRange.Address(ReferenceStyle:=xlR1C1), kolon)
  rakke = Mid(ActiveSheet.UsedRange.Address(ReferenceStyle:=xlR1C1), start + 1, slut - start - 1)
Set Fra = Range(Fra(1, 1), Fra(rakke, 1)) 'ActiveSheet.UsedRange.Rows.Count, 1)) 'Ad"R" & rakke & "C" & kolonne
End If
    Set Til = Application.InputBox("marker 1. celle i outputområde", "outputområde", , , , , , 8)
    On Error Resume Next
    For Each Cell In Fra
        NoDupes.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    Err.Clear
    On Error GoTo 0
    For Each Item In NoDupes
        Til.Offset(i, 0) = Item
        i = i + 1
    Next
    Range(Til, Til.Offset(i - 1, 0)).sort Key1:=Til, Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub

enig aheiss. her er mit forslag
Sub listuniq()
Dim NoDupes As New Collection
Dim strCheck As String
Dim Fra As Range, Til As Range, Cell As Range
Dim i As Long
    Set Fra = Application.InputBox("marker 1. celle i inputområde (een kolonne)", "Inputområde", , , , , , 8)
    Set Fra = Range(Cells(Fra.Row, Fra.Column), Cells(65536, Fra.Column).End(xlUp))
    Set Til = Application.InputBox("marker 1. celle i outputområde", "outputområde", , , , , , 8)
    On Error Resume Next
    For Each Cell In Fra
        NoDupes.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    Err.Clear
    On Error GoTo 0
    For Each Item In NoDupes
        Til.Offset(i, 0) = Item
        i = i + 1
    Next
    Range(Til, Til.Offset(i - 1, 0)).Sort Key1:=Til, Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub

Smart nok. Den der End(xlUp)..xlDown osv. er ret effektiv må man sige. Jeg bør have den i tankerne noget oftere :-)

Tak, det glæder mig at du er istand til at gennemskue mine lidt mærkelige koder og kan komme med forbedringsforslag.

:)
Det var lige godt fandens, både hurtigt og godt!

aheiss, dit første forslag gør LIGE det jeg vil have, det er godt nok ikke fordi vi har så mange arbejdsnumre (17) og ikke så mange poster i kolonnen (max. 150), men en hybrid af de 2 forslag ville være dejligt. :)

Jeg vil altså have bak's forslag, men med din "manglende" nødvendighed for "aktivt" at vælge kolonne/kolonnestart. Samtidig vil jeg ikke have den til at tage det aktive sheet, men sheetet Data. Kan det lade sig gøre og hvordan ser koden SÅ ud?

Da jeg bruger Option Explicit, ser jeg jo at den brokker sig over Item, hvilken datatype er Item?

Skal outputområdet også være fast ? Her er en ny kode. Du skal stå i det ark hvor data skal vises. Skift " ' " mellem række 8 og 9, for at vælge aktivt outputområde eller fast "I1". Item er Variant    :

Sub listuniq()
Dim NoDupes As New Collection
Dim strCheck As String
Dim Fra As Range, Til As Range, Cell As Range, fra2 As Range, item As Variant
Dim i As Long
    Set Fra = Sheets("Data").Range("a:a")
    Set fra2 = Range(Fra(3, 1), Fra(65536, 1).End(xlUp))
    'Set Til = Application.InputBox("marker 1. celle i outputområde", "outputområde", , , , , , 8)
    Set Til = Range("i1")
    On Error Resume Next
    For Each Cell In fra2
        NoDupes.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    Err.Clear
    On Error GoTo 0
    For Each item In NoDupes
        Til.Offset(i, 0) = item
        i = i + 1
    Next
    Range(Til, Til.Offset(i - 1, 0)).sort Key1:=Til, Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub

Jeg VILLE jo gerne have resultatet i et andet ark (kender intet til Excel object-modellen), men dette er også fint nok. Takker for hjælpen, aheiss.
Smid et svar, så jeg kan rewarde dig.

Her et svar. Hvis jeg husker det kigger jeg lige på det i morgen - det med et andet ark - hvis du altså stadig er interesseret ! :-)

aheiss, det ER jeg! :)
Takker indtil videre

Det er såmend rimeligt simpelt. Nedenstående lægger dataene i ARK2 Fra celle A1 og nedefter. Dvs. du selv lige må rette outpuområdet til :
____________________________________________________________________
Sub listuniq()
Dim NoDupes As New Collection
Dim strCheck As String
Dim Fra As Range, Til As Range, Cell As Range, fra2 As Range, item As Variant
Dim i As Long
    Set Til = Sheets("Ark2").Range("a1")  'RET SELV OUTPUTOMRÅDE
    Set Fra = Sheets("Data").Range("a:a")
    Set fra2 = Range(Fra(3, 1), Fra(65536, 1).End(xlUp))
    On Error Resume Next
    For Each Cell In fra2
        NoDupes.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    Err.Clear
    On Error GoTo 0
    For Each item In NoDupes
        Til.Offset(i, 0) = item
        i = i + 1
    Next
    Range(Til, Til.Offset(i - 1, 0)).Sort Key1:=Til, Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub