VBA: Werte auf Eindeutigkeit prüfen

[Lutz Fricke]

Hallo wertes Forum,

ich habe da ein Problem beim Feststellen, ob es in einer Spalte mehr als einen Wert gibt.
Ich habe zur Veranschaulichung eine Beispieldatei mit dem folgenden Code angehängt:

Code:

Sub DictTest()

Dim wksShippedOrders As Worksheet
Dim dictShipToParty As Object
Dim lngZeileDaten As Long, lngLetzteZeileDaten As Long, lngSpalteQty As Long, lngSpalteShipToParty As Long
Dim lngShipToParty As Long

Set wksShippedOrders = ThisWorkbook.Worksheets("Sheet1")
Set dictShipToParty = CreateObject("scripting.dictionary")

lngSpalteShipToParty = 4
lngSpalteQty = 11

With wksShippedOrders
    lngLetzteZeileDaten = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
    For lngZeileDaten = 2 To lngLetzteZeileDaten
        If .Cells(lngZeileDaten, lngSpalteQty).Value > 0 Then
       
            lngShipToParty = dictShipToParty.Item(CLng(.Cells(lngZeileDaten, lngSpalteShipToParty).Value))
            Debug.Print CLng(.Cells(lngZeileDaten, lngSpalteShipToParty).Value), dictShipToParty.Item(dictShipToParty.keys()(0)), dictShipToParty.Items()(0), "Test"
           
'  Hier steht noch mehr Code....
           
        End If
    Next lngZeileDaten
End With

If dictShipToParty.Count > 1 Then
    MsgBox "Die Aufträge gehören zu mehr als einem Kunden." & vbNewLine & _
        "Das Program wird beendet.", vbCritical + vbSystemModal, Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1)
    End
End If

End Sub

Mein erster Gedanke war, dass ich mir ein Dictionary nehme, das mit dem fraglichen Wert als Key befülle und am Ende prüfe, wieviele Keys ich habe. (Sicherlich gibt es auch andere Wege...).
Das funktioniert auch. Wenn mehr als ein verschiedener Wert in der Spalte steht, wird das Makro über die MsgBox beendet.

Jetzt habe ich festgestellt, dass ich aber diesen einen Key später nochmal brauche.
Ich habe versucht, die Varibale lngShipToParty, die ich zum Einlesen des Dictionaries nutze, zu verwenden, aber die ist "0".
Sowohl das Item als auch der Key des Dictionariies ist leer.

Natürlich habe ich in snb's Almanach über Dictionaries studiert, komme aber nicht weiter (dictShipToParty.Items()(1) gibt einen Fehler Laufzeitfehler 9: Index außerhalb des gültigen Bereichs).
Was mache ich verkehrt? Warum funktioniert die Abfrage am Ende aber ich bekomme den Wert mnicht raus?

Vielen Dank für Eure Hilfe,
Lutz

  Beispiel Dictionary.xlsm (Größe: 17,63 KB / Downloads: 10)

[schauan]

Hallöchen,

damit
dictShipToParty.Items()(1)

bist Du eins zu weit, es geht nur dictShipToParty.Items()(0),

---

.. oder Du prüfst es so:
Application.Evaluate("SUM(1/COUNTIF(D2:D25,D2:D25))")

[Lutz Fricke]

Hallo André,

vielen Dank für deine Antwort.
Ich habe ja im Code dictShipToParty.Items()(0) stehen, bekomme aber mit Debug.Print dictShipToParty.Items()(0) keinen Wert raus. Auch dictShipToParty.Item(dictShipToParty.keys()(0)) ist leer.
Wo ist der Haken? Warum sehe ich den Key nicht ( ein Item dürfte ich ja eigentlich auch nicht haben)?

Vielen Dank auch für den zweiten Lösungsweg, hilft mir natürlich bei der Lösung meiner Aufgabe.

Gruß,
Lutz

[schauan]

Hallöchen,

andersrum wird ein Schuh draus. Du siehst den Key, aber keinen Inhalt. Siehst Du übrigens deutlich im Überwachungsfenster
dictShipToParty.keys()(0) --> 103570
dictShipToParty.Items()(0) --> leer

besser wäre
dictionary.Add Key, Value
oder
dictionary(Key) = Value

[snb]

Code:

Sub M_snb()
  sn = Tabelle1.Cells(1).CurrentRegion
 
  With CreateObject("scripting.dictionary")
    For j = 2 To UBound(sn)
      If sn(j, 11) > 0 Then .Item(sn(j, 4)) = sn(j, 11)
      Debug.Print "Item(sn(j,4)): " & vbTab & .Item(sn(j, 4))
      Debug.Print "items()(.count-1):  " & vbTab & .items()(.Count - 1)
      Debug.Print "keys()(.count-1):   " & vbTab & .keys()(.Count - 1)
    Next
  End With
End Sub

[Lutz Fricke]

Hallo André, hallo snb,

vielen Dank für Eure Hilfe.

Dank Euch habe ich jetzt auch meinen Fehler gefunden.
Was zur Hölle wollte ich mit dictShipToParty.Item(dictShipToParty.keys()(0)) ausgeben lassen? Das da nicht das richtige Ergebnis rauskommen kann ist ja logisch...

Trotzdem noch eine Frage an snb:
Auf deiner Homepage (immer wieder eine riesige Hilfe) steht bei den Dictionatries unter Punkt 10 A list of unique elements der folgende Code:

Code:

With CreateObject("scripting.dictionary")
For Each it In Array(22, 33, 44, 22, 3, 22, 55, 44)
y = .Item(it)
Next
MsgBox .Count ' 5 unique keys because of the replication of 44 and 22
MsgBox Join(.Keys, vbLf)
End With

Ist für eine Liste mit eindeutigen Werten perfekt (daher auch der Weg meiner Wahl gewesen).
Aber warum kann mann "y" nicht ausgeben?

Gruß,
Lutz

[snb]

Weil jedes Item leer ist; es wird nur ein key kreiert.
Es wird eine Reihe von 'Unique keys' erstellt; dan brauchen die items keinen Inhalt.

Statt
 

Code:

y=.item(it)

Kann man auch schreiben:
 

Code:

.item(it)=null

[snb]

Bonus:

Code:

Sub M_snb()
  With CreateObject("scripting.dictionary")
    x0 = .Item("snb")
   
    MsgBox VarType(x0)
    MsgBox TypeName(x0)
    MsgBox .Item("snb")
    MsgBox VarType(.Item("snb"))
    MsgBox TypeName(.Item("snb"))
   
    .Item("snb_01") = Empty
    MsgBox VarType(.Item("snb_01"))
    MsgBox TypeName(.Item("snb_01"))
    MsgBox .Count
  End With
End Sub

[Lutz Fricke]

Super.
Vielen Dank.