Returner alle unike elementer fra et celleområde

Makroen nedenfor vil returnere en collection med de unike verdiene fra et angitt celleområde.
Man kan eventuelt benytte separate nøkkelverdier og enhetsverdier.

Function GetUniqueItems(KeyRange As Range, Optional ItemRange As Range) As Collection
Dim r As Long, c As Long, varItem As Variant, strKey As String
    If Not KeyRange Is Nothing Then
        Set GetUniqueItems = New Collection
        With KeyRange
            For c = 1 To .Columns.Count
                For r = 1 To .Rows.Count
                    strKey = vbNullString
                    varItem = vbNullString
                    On Error Resume Next
                    strKey = Trim(CStr(.Cells(r, c).Value))
                    If Not ItemRange Is Nothing Then
                        varItem = ItemRange.Cells(r, c).Value
                    Else
                        varItem = .Cells(r, c).Value
                    End If
                    If Len(strKey) > 0 Then
                        GetUniqueItems.Add varItem, strKey
                    End If
                    On Error GoTo 0
                Next r
                DoEvents
            Next c
        End With
        If GetUniqueItems.Count = 0 Then
            Set GetUniqueItems = Nothing
        End If
    End If
End Function

Sub TestCopyUniqueItems()
Dim coll As Collection, i As Long
    Set coll = GetUniqueItems(Range("A1:A100"))
    If coll Is Nothing Then Exit Sub
    
    Range("C1:C100").Clear
    For i = 1 To coll.Count
        Range("C1").Offset(i - 1, 0).Formula = coll(i)
    Next i
End Sub

Makroen nedenfor vil ved hjelp ab den innebygde funksjonaliteten i Excel returnere alle unike elementer i et regnearkområde til et annet:

Sub FindUniqueValues(SourceRange As Range, TargetCell As Range)
    SourceRange.AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=TargetCell,  Unique:=True
End Sub

Man kan benytte makroen slik for å returnere alle unike elementer fra regnearkområdet A1:A100 til celle C1 og nedover:

Sub TestFindUniqueValues()
    FindUniqueValues Range("A1:A100"), Range("C1")
End Sub

Dokumentet er sist oppdatert 2008-08-14 21:53:56 Utskriftsvennlig versjon