Eindimensionales Array ohne doppelte ausgeben

Question

Hallo,

ich habe folgendes Problem mit einem eindimensionalen Array.

Sub EindimensionalesArray()
Dim ArrLst As Object
Dim lngZeile, lngZeileMax As Long

Set ArrLst = CreateObject("System.Collections.ArrayList")
    With Tabelle1
    .Range("K:K").ClearContents
    lngZeileMax = .Range("A" & .Rows.Count).End(xlUp).Row
    'ArrayList füllen
        For lngZeile = 2 To lngZeileMax
        ArrLst.Add .Range("A" & lngZeile).Value
        Next lngZeile
    ArrLst.Sort         'Aufsteigend sortieren
    'oder
    'ArrLst.Reverse     'Absteigend sortieren
    .Range("K1").Value = Range("A1").Value
    'ArrList in Tabelle ausgeben
    .Range("K2:K" & lngZeileMax).Value = _
    Application.WorksheetFunction.Transpose(ArrLst.toArray)
    'Spaltenbreite automatisch anpassen
    .Range("A:K").Columns.AutoFit
    End With
End Sub

Soweit funktioniert das Makro ja einwandfrei, ich stehe nur vor dem Problem, dass in Spalte K auch die doppelten ausgegeben werden.

Wie muss ich das Makro abändern, damit die doppelten ausgegebenen Werte nicht ausgegeben werden?

Danke für eure Hilfe

bg Lukas

Answer 1

Hallo Lukas,

mit .Contains kann man wohl prüfen, ob ein Eintrag schon vorhanden ist. Habs jetzt nicht ausprobiert aber ungetestet müsste es etwa so funktionieren:

Sub EindimensionalesArray()
Dim ArrLst As Object
Dim lngZeile, lngZeileMax As Long

Set ArrLst = CreateObject("System.Collections.ArrayList")
    With Tabelle1
    .Range("K:K").ClearContents
    lngZeileMax = .Range("A" & .Rows.Count).End(xlUp).Row
    'ArrayList füllen
        For lngZeile = 2 To lngZeileMax
          If Not ArrLst.Contains(.Range("A" & lngZeile).Value) Then _
          ArrLst.Add .Range("A" & lngZeile).Value
        Next lngZeile
    ArrLst.Sort         'Aufsteigend sortieren
    'oder
    'ArrLst.Reverse     'Absteigend sortieren
    .Range("K1").Value = Range("A1").Value
    'ArrList in Tabelle ausgeben
    .Range("K2:K" & ArrLst.Count + 1).Value = _
    Application.WorksheetFunction.Transpose(ArrLst.toArray)
    'Spaltenbreite automatisch anpassen
    .Range("A:K").Columns.AutoFit
    End With
End Sub

Gruß Mr. K.

Answer 2

Warum so kompliziert!

Ein Ansatz!

Sub NoDuplikate()
With Worksheets(1)
.Range("A:A").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
.Range(.Cells(2, 1), .Cells(.Range("A" & Rows.Count).End(xlUp).Row, 1)).Copy .Cells(2, 11)
.Range("A:A").AdvancedFilter Action:=xlFilterInPlace, Unique:=False
.Range("A:K").Columns.AutoFit
End With
End Sub

Answer 3

Danke Mr.K

funktioniert einwandfrei!

bg Lukas