Office: Liste ohne Duplikate erstellen mit Dictionary Object

myfake · 25. Juni 2018

Hallo zusammen,

ich versuche mich seit einiger Zeit in die Arrays einzuarbeiten und bin dabei auf das Dictionary Object gestoßen. Den gefundenen Code habe ich etwas verändert, damit es zu meiner Anforderung passt:

Code:

Sub DictionaryObjektAnwenden()

Dim lngZeile As Long
Dim lngZeileMax As Long, lngZeileMax2 As Long
Dim objDic As Object
Dim lngAnzahl As Long
Dim wsf As WorksheetFunction

Set objDic = CreateObject("Scripting.Dictionary")
Set wsf = Application.WorksheetFunction

Worksheets("Zusammenfassung").Range("B11:B1000").Clear

With Worksheets("Quelle1")

lngZeileMax = .Cells(.Rows.Count, 3).End(xlUp).Row

For lngZeile = 11 To lngZeileMax

If Not objDic.exists(.Cells(lngZeile, 3).Value) Then
objDic.Add .Cells(lngZeile, 3).Value, .Cells(lngZeile, 4).Value
Else

End If

Next lngZeile

End With

With Worksheets("Quelle2")

lngZeileMax2 = .Cells(.Rows.Count, 3).End(xlUp).Row

For lngZeile = 11 To lngZeileMax2

If Not objDic.exists(.Cells(lngZeile, 3).Value) Then
objDic.Add .Cells(lngZeile, 3).Value, .Cells(lngZeile, 4).Value
Else

End If

Next lngZeile

End With

lngAnzahl = objDic.Count

With Worksheets("Zusammenfassung")

.Range("B11:B" & lngAnzahl).Value = wsf.Transpose(objDic.keys)

End With

Set objDic = Nothing

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Erreicht werden soll folgendes - aus 2 Quellsheets sollen Bezeichnungen in ein Array gelesen werden und dann eine Liste ohne Duplikate erstellt werden. Diese "Unique-Liste" soll dann auf dem Sheet "Zusammenfassung" in Spalte B geschrieben werden.

Obiger Code läuft zwar fehlerfrei durch, aber bei der Überprüfung ist mir aufgefallen, dass unterwegs wohl 6 Ticker verloren gegangen sind.

Kann mir jemand sagen, wo mein Fehler liegt?

Vielen Dank schon einmal im Voraus.

cu
myfake

:)

Nepumuk · 26. Juni 2018

Hallo,

teste mal:

Code:

Option Explicit

Sub DictionaryObjektAnwenden()
Dim lngZeile As Long
Dim objDic As Object
Dim lngAnzahl As Long
Dim wsf As WorksheetFunction
Dim avntValues As Variant

Set objDic = CreateObject("Scripting.Dictionary")
Set wsf = Application.WorksheetFunction

Worksheets("Zusammenfassung").Range("B11:B10000").Clear

With Worksheets("Quelle1")
avntValues = .Range(.Cells(11, 3), .Cells(.Cells(.Rows.Count, 3).End(xlUp).Row, 4)).Value2
End With

For lngZeile = LBound(avntValues) To UBound(avntValues)

If Not objDic.Exists(avntValues(lngZeile, 1)) Then _
objDic.Add avntValues(lngZeile, 1), avntValues(lngZeile, 2)

Next lngZeile

With Worksheets("Quelle2")
avntValues = .Range(.Cells(11, 3), .Cells(.Cells(.Rows.Count, 3).End(xlUp).Row, 4)).Value2
End With

For lngZeile = LBound(avntValues) To UBound(avntValues)

If Not objDic.Exists(avntValues(lngZeile, 1)) Then _
objDic.Add avntValues(lngZeile, 1), avntValues(lngZeile, 2)

Next lngZeile

lngAnzahl = objDic.Count

With Worksheets("Zusammenfassung")
.Range("B11").Resize(lngAnzahl, 1).Value = wsf.Transpose(objDic.keys)
'.Range("E1").Resize(lngAnzahl, 1).Value = wsf.Transpose(objDic.items)
End With

Set wsf = Nothing
Set objDic = Nothing

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Mc Santa · 26. Juni 2018

Es sind erwartungsgemäß 10 Zeilen zu wenig, weil du zwar die Anzahl bestimmst, aber dann den Ausgabebereich von Zeile 11 bis Zeile_Anzahl erstellst.
Code:

.Range("B11:B" & lngAnzahl)
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Besser ist der Vorschlag von Nepumuk:
Code:

Range("B11").Resize(lngAnzahl, 1)
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

VG, Santa

myfake · 26. Juni 2018

Ahhhh - ihr seid super! *Smilie Ich habe zwar immer wieder an die Zeilenverschiebung gedacht, aber an dem Punkt halt nicht.

Den Code konnte ich dann ganz einfach anpassen:
Code:

.Range("B11:B" & lngAnzahl + 10).Value = wsf.Transpose(objDic.keys)
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Aber die Lösung von Nepomuk werde ich mir trotzdem nochmal genauer anschauen. Denn mit LBound und UBound zu arbeiten scheint mir deutlich besser.

Nochmals Danke für die schnelle Hilfe!

cu
myfake

Mc Santa · 26. Juni 2018

Du solltest unbedingt mit Resize() arbeiten, und niemals mit einer manuellen Verschiebung.

Diese Fehler sind die schlimmsten die es gibt, denn es läuft alles und sieht auch auf den ersten Blick alles richtig aus. Erst wenn man genauer hinsieht fehlen bei 600 Einträgen auf einmal ein paar. Solche Fehler findest du nur schwer und häufig fallen sie an ganz anderer Stelle auf, als dort wo sie entstehen.

Bitte arbeite unbedingt mit dieser Variante:
Code:

Range("B11").Resize(lngAnzahl, 1).Value = wsf.Transpose(objDic.keys)

Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

myfake · 27. Juni 2018

Hallo Mc Santa,

vielen Dank für den Hinweis! Habe ich gleich entsprechend verändert *Smilie

cu
myfake

Office: Liste ohne Duplikate erstellen mit Dictionary Object

Liste ohne Duplikate erstellen mit Dictionary Object

Liste ohne Duplikate erstellen mit Dictionary Object

Liste ohne Duplikate erstellen mit Dictionary Object

Liste ohne Duplikate erstellen mit Dictionary Object - Similar Threads - Liste Duplikate erstellen

Zweispaltige Liste umsortieren

Excel Kalender in Word als Liste exportieren

Liste aus verschiedenen Listen ohne Duplikate

Liste von Werten mit zwei Bedingungen verlängern, zeilenabhängige Duplikate erzeugen

Einträge in gefilterter Liste ohne Duplikate zählen

Liste durchsuchen, duplikate löschen und wo anders kopieren

Liste von Namen in anderer Spalte ohne Duplikate!