Doppelte im Array filtern

Herbert_Grom · 2023-05-23T14:55:13+00:00

Hallo, Aus der Liste A16:A83 möchte ich nur die mehrfach vorkommenden Namen ermitteln und diese dann, ohne Duplikate, in die Spalte K kopieren. Das klappt mit dem Makro in der beigef. AM perfekt. Meine Frage ist jedoch, ob ich das Ganze nicht schon gleich im Array filtern kann, damit am Ende diese 3 Namen eingetragen werden? Ich steh voll aufm Schlauch. Vielen Dank im Voraus. https://www.herber.de/bbs/user/159286.xlsm Servus

Ich entdecke erst jetzt, dass ich die Aufgabenstellung falsch verstanden habe (wäre ja zu einfach gewesen ;-) und somit meinen Vorschlag keine passende Lösung darstellt.
Daniels Vorschlag ist die Lösung.

Ich habe mit der Idee, Eintrag in der Dictionary zu löschen, wenn nur einmal vorkommt, aber es funktioniert nicht so.
Ausserdem beansprucht das Löschen eines Dictionary-Eintrags wahrscheinlich mehr Prozessorzeit, als einen separaten Dictionary aufzubauen (so ist mindestens bei Collection. Bei Dictionary habe ich den Test nicht gemacht, sollte aber ähnlich sein).
Eine zweite Dictionary ist auch Prozessorzeit-teurer, als eine Zeichenkette zu bauen und zu splitten.

Sub test()
'basierend auf Daniels Lösung, aber nicht besser ;-)
Dim x
Dim Erg1
Dim Erg2

    Set Erg1 = CreateObject("scripting.dictionary")
    Set Erg2 = CreateObject("scripting.dictionary")

    With Sheets("Liste")
        For Each x In .Range("A16:A83").Value
            Erg1(x) = Erg1(x) + 1
        Next
    
        For Each x In Erg1.Keys
            If Erg1(x) >= 2 Then Erg2(x) = 1
        Next
    
        .Range("K1").Resize(Erg2.Count, 1) = Application.Transpose(Erg2.Keys)
    End With
End Sub

Bei der geringe Menge an Einträge wäre auch eine direkte Abgabe in Zelle auch nicht langsam (bei blockierten Updating und Events)

Sub test()
'basierend auf Daniels Lösung
Dim x
Dim Erg1
Dim Z As Range

    Set Erg1 = CreateObject("scripting.dictionary")
    With Sheets("Liste")
        For Each x In .Range("A16:A83").Value
            Erg1(x) = Erg1(x) + 1
        Next

        Set Z = .Range("K1")
        For Each x In Erg1.Keys
            If Erg1(x) >= 2 Then
                Z.Value = x
                Set Z = Z.Offset(1)
            End If
        Next
    End With
End Sub

VG
Yal

Hi
naja, der Vorschlag von snb ist eigentlich nur deshalb kürzer, weil er auf Variablendeklaration verzichtet (was ich nicht mache) und weil der den Zellbereich fest vorgibt und ich die automatische Ermittlung eingebaut habe.

wenn ich meinen Code im snb-Stil schreibe, dann ist er eigentlich fast genauso lang.

Sub M_Daniel()
Set Erg1 = CreateObject("scripting.dictionary")
For Each x In Range("A1:A10").Value
    Erg1(x) = Erg1(x) + 1
Next
For Each x In Erg1.keys
    If Erg1(x) >= 2 Then Erg2 = Erg2 & "|" & x
Next
Erg2 = WorksheetFunction.Transpose(Split(Mid(Erg2, 2), "|"))
Cells(1, 11).Resize(UBound(Erg2), 1) = Erg2
End Sub

Sub M_snb()
sn = Filter(Application.Transpose(Range("A1:A10")), "")
Do Until UBound(sn) = -1
  If UBound(Filter(sn, sn(0))) > 0 Then c00 = c00 & "_" & sn(0)
  sn = Filter(sn, sn(0), 0)
Loop
sn = Split(Mid(c00, 2), "_")
Cells(1, 11).Resize(UBound(sn) + 1) = Application.Transpose(sn)
End Sub

Forumthread: Doppelte im Array filtern

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Doppelte im Array filtern

Forumthread: Doppelte im Array filtern

25 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread