Doppelte im Array filtern

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub M_snb() sn = Filter(Application.Transpose(Range("A16:A83")), "") 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

Sub Kopieren_ohne_Duplikate() 'Liste Kopieren ohne Duplikate per Erweitertem Filter Range([A16], [A16].End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("K16"), Unique:=True End Sub

Private Sub UserForm_Activate() Dim arr() As Variant, lngT As Long, wsListe As Worksheet Set wsListe = Worksheets("Liste") ReDim arr(0) For lngZ = 16 To 83 If Application.CountIf(wsListe.Range("A1:A" & lngZ), wsListe.Cells(lngZ, 1)) = 2 Then With Me.ListBox_Verkäuferauswahl .AddItem (wsListe.Cells(lngZ, 1)) End With 'Falls das Array weiter verarbeitet werden soll : arr(UBound(arr)) = wsListe.Cells(lngZ, 1) ReDim Preserve arr(UBound(arr) + 1) End If Next End Sub

Option Base 1 Sub test() Dim arr, x Dim Erg1 Dim Erg2 Set Erg1 = CreateObject("scripting.dictionary") With Sheets("Liste").Range("A15") For Each x In Range(.Offset(1, 0), .End(xlDown)).Value Erg1(x) = Erg1(x) + 1 Next End With 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 test() Dim dic Dim Z Set dic = CreateObject("Scripting.Dictionary") For Each Z In Worksheets(1).Range("A16:A83").Value dic(CStr(Z)) = 1 Next Worksheets(1).Range("K1").Resize(dic.Count, 1).Value = Application.Transpose(dic.keys) End Sub

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

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

Hallo zusammen,

kurz ist immer gut, aber nicht ausschlaggebend. Meiner Erachtens ist wichtiger, wie schnell man den Code wiederlesen kann und zuverlässig dessen Bedeutung erfassen kann. Nicht nach 2 Tage, sondern nach 6 Monaten.

Es hängt natürlich an vielen Faktoren, u.a. an Gewonnheiten, z.B. ob man eher mit Dictionary oder Verkettung von Zeichenkette wohlfühlt. Im Laufe der Zeit entwickeln sich die eigenen Boiler plates, also die wiederkehrenden Implementierungsmuster, die man auf einem Blick erkennt und erfasst. Alles anderes ist Fall-spezifisch und Bedarf gezielte Aufmerksamkeit. Und da ist kurz und kompakt nicht unbedingt ein guter Freund.

Unter diese Gesichtspunkt halte ich die Lösung mit 2 Dictionaries für schlank und leicht zu erfasssen. Ich würde aber die Namen Erg1 und Erg2 so ändern, dass diese bildlich leichter zu unterscheiden sind, so was wie "Basis" und "Erg", weil im zweiten For nur mit erhöhter Aufmerksamkeit zu entdecken ist, dass beide vorkommen.

VG
Yal

Sub til() Dim lKaeuferCount&, lAnzKaeuf&, wbKfLst As Worksheet, lDoppelte&, _ sSuchName$, x& Dim dict As Object Set dict = CreateObject("Scripting.Dictionary") Set wbKfLst = Sheets("Liste") x = 1 With wbKfLst lAnzKaeuf = .Cells(Rows.Count, "A").End(xlUp).Row - 15 Range("K1:K100").ClearContents For lKaeuferCount = 1 To lAnzKaeuf sSuchName = .Cells(lKaeuferCount + 15, "A") lDoppelte = Application.WorksheetFunction.CountIf(.Range("A1:A100"), "=" & sSuchName) If lDoppelte > 1 Then ' Aufnahme doppelte Werte im Dictionary verhindern! dict(sSuchName) = 0 x = x + 1 End If Next lKaeuferCount ' * Inhalt Dictionary in Tabelle eintragen .Cells(1, "K").Resize(dict.Count) = WorksheetFunction.Transpose(dict.Keys) End With Set dict = Nothing Set wbKfLst = Nothing End Sub

Private Sub UserForm_Initialize() Dim sn, c00 sn = Filter(Application.Transpose(Tab6.Range("A16:A" & Tab6.Cells(Rows.Count, "A").End(xlUp).Row)), "") 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), "_") ListBox_Verkäuferauswahl.List = Application.Transpose(sn) End Sub

Beliebteste Forumthreads (12 Monate)

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Doppelte im Array filtern

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

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread