Eine Funktion zum Vergleichen. Klingt eigentlich unnötig. Doch vergleicht sie alles Mögliche. Arrays untereinander, Dictionaries, Null mit Empty etc.
'Ein einfacher Vergleich 2er Werte ? compaire(1234, 1234.00) True 'Dasselbe mit Typenprüfung. Der Erste Parameter ist ein Integer, der Zweite ein Double ? compaire(1234, 1234.00, cpVarTypeStrong) False 'Dasselbe Spiel mit einem Vergleich 0 und Null ? compaire(Null, 0) True ? compaire(Null, 0, cpVarTypeStrong) False
Für die Ausgabe der Resultate verwendete ich die Funktion [VBA] print_r().
Ich vergleiche mal die 2 folgenden Arrays miteinander print_rm array("1","2","2",array("4","5")), array(2,1,array(5.0,4.0),2) <Variant()> ( [0] => <String> 1 [1] => <String> 2 [2] => <String> 2 [3] => <Variant()> ( [0] => <String> 4 [1] => <String> 5 ) ) <Variant()> ( [0] => <Integer> 2 [1] => <Integer> 1 [2] => <Variant()> ( [0] => <Double> 5 [1] => <Double> 4 ) [3] => <Integer> 2 ) 'Normalverlgeich. Es wird Index und Value verglichen. Das ganze ohne Typenvergleich ? compaire(array("1","2","2",array("4","5")), array(2,1,array(5.0,4.0),2)) False 'Nur ValueVergleich, immer noch ohne Typenvergleich ? compaire(array("1","2","2",array("4","5")), array(2,1,array(5.0,4.0),2),cpArrayValuesOnly) True 'Und jetzt mit Mit Typenvergleich ? compaire(array("1","2","2",array("4","5")), array(2,1,array(5.0,4.0),2), cpArrayValuesOnly+cpVarTypeStrong) False
Für die folgenden Vergleich mit Dictionaries verwende ich die Funktion [VBA] cDict() um die Dictionaries zu erstellen
Für die Ausgabe der Resultate verwendete ich die Funktion [VBA] print_r().
'Die Arrays: print_rm cDict("A", 1, "B", 2.0) , cDict("B", 2, "A", 1) <Dictionary> ( [A] => <Integer> 1 [B] => <Double> 2 ) <Dictionary> ( [B] => <Integer> 2 [A] => <Integer> 1 ) 'Erster Vergleich: Check ob beide dieselben Einträge mit denselben Werten beinhaltet ? compaire(cDict("A", 1, "B", 2.0) , cDict("B", 2, "A", 1)) True 'Überprüft, ob die 2 Objekte dieselbe Instanz sind ? compaire(cDict("A", 1, "B", 2.0) , cDict("B", 2, "A", 1), cpInstanceCompaire) False 'Zusätzlich zu den Keys und Values auf den Values noch ein Typenvergleich ? compaire(cDict("A", 1, "B", 2.0) , cDict("B", 2, "A", 1), cpVarTypeStrong) False
Attribute VB_Name = "udf_compaire" '------------------------------------------------------------------------------- 'File : udf_compaire.bas ' Copyright mpl by ERB software ' All rights reserved ' http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/compaire 'Environment : VBA 2010 + 'Version : 1.0.1 'Name : compaire 'Author : Stefan Erb (ERS) 'History : 12.09.2014 - ERS - Creation ' 16.09.2014 - ERS - Neue Version von cast() '------------------------------------------------------------------------------- Option Explicit Public Enum cpComapireParams cpNone = 0 cpVarTypeStrong = 2 ^ 0 'Datentype aus varType() muss ebenfalls übereinstimmen cpInstanceCompaire = 2 ^ 1 'Objekte nur auf Referenz prüfen. Gilt vor allem für Dictionaries cpArrayValuesOnly = 2 ^ 2 'Bei Arrayvergleich den Index ignorieren End Enum '/** ' * Vergleicht 2 Variaben ' * @param Variant ' * @param Variant ' * @return Boolean ' */ Public Function compaire(ByRef iVar1 As Variant, ByRef iVar2 As Variant, Optional ByVal iParams As cpComapireParams = cpNone) As Boolean Dim i As Integer, j As Integer, k As Integer 'Typenvergleich bei Parameter cpVarTypeStrong durchführen If iParams And cpVarTypeStrong Then If Not (VarType(iVar1) = VarType(iVar2)) Then Exit Function 'Null Vergleich If IsNull(iVar1) Or IsNull(iVar2) Then compaire = IsNull(cast(vbNull, iVar1)) And IsNull(cast(vbNull, iVar2)) 'in Array vergleichen ElseIf (iParams And cpArrayValuesOnly) And IsArray(iVar1) And IsArray(iVar2) Then If Not UBound(iVar1) - LBound(iVar1) = UBound(iVar2) - LBound(iVar2) Then Exit Function Dim check() As Boolean: ReDim check(LBound(iVar2) To UBound(iVar2)) For i = LBound(iVar1) To UBound(iVar1) For j = LBound(iVar2) To UBound(iVar2) If Not check(j) Then compaire = compaire(iVar1(i), iVar2(j), iParams) If compaire Then check(j) = True Exit For End If End If Next j If Not compaire Then Exit Function Next i ElseIf IsArray(iVar1) And IsArray(iVar2) Then If Not LBound(iVar1) = LBound(iVar2) And UBound(iVar1) = UBound(iVar2) Then Exit Function For i = LBound(iVar1) To UBound(iVar1) compaire = compaire(iVar1(i), iVar2(i), iParams) If Not compaire Then Exit Function Next i 'in Array suchen 'Objekt-Vergleich ElseIf IsObject(iVar1) And IsObject(iVar2) Then 'Dictionary kann über den Key verglichen werden If TypeName(iVar1) = "Dictionary" And TypeName(iVar2) = "Dictionary" And Not CBool(iParams And cpInstanceCompaire) Then If iVar1.count = iVar2.count Then Dim keys As Variant: keys = iVar1.keys For k = 0 To iVar1.count - 1 If Not iVar2.exists(keys(k)) Then Exit Function If Not compaire(iVar1(keys(k)), iVar2(keys(k)), iParams) Then Exit Function Next k compaire = True End If 'Objekte auf Referenz prüfen Else compaire = (iVar1 Is iVar2) End If 'Value-Vergleich ElseIf Not IsObject(iVar1) And Not IsObject(iVar2) And Not IsArray(iVar1) And Not IsArray(iVar2) Then compaire = (iVar1 = cast(VarType(iVar1), iVar2)) End If End Function '/** ' * Wandelt einen String wenn möglich in das angegebene Format um ' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cast ' * V1.0.1 ' * @param VbVarType ' * @param Variant ' * @param Boolean : Bei True wird ein Fehler greworfen, wenn der cast1() nichtr durchfürbar ist. Ansonsten wir der Eingabewert zurückgegeben ' * @return Variant ' */ Private Function cast(ByVal iType As VbVarType, ByVal iVar As Variant, Optional ByVal iStrong As Boolean = False) As Variant On Error GoTo Err_Handler cast = iVar Select Case iType Case vbNull, vbEmpty If Not (iVar = Empty Or IsNull(iVar)) Then Err.Raise 13 'Type mismatch cast = Choose(iType + 1, Empty, Null) Case vbArray: cast = IIf(IsArray(iVar), iVar, Array(iVar)) Case vbDate: cast = CDate(iVar) Case vbString: cast = CStr(iVar) Case vbInteger: cast = CInt(iVar) Case vbLong: cast = CLng(iVar) Case vbDouble: cast = CDbl(iVar) Case vbDecimal: cast = CDec(iVar) Case vbByte: cast = CByte(iVar) Case vbSingle: cast = CSng(iVar) Case vbCurrency: cast = CCur(iVar) Case Else: cast = CVar(iVar) End Select Exit_Hanlder: Exit Function Err_Handler: If iStrong Then Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext cast = iVar End Function