User Tools

Site Tools


vba:functions:compaire

This is an old revision of the document!


[VBA] compaire()

Eine Funktion zum Vergleichen. Klingt eigentlich unnötig. Doch vergleicht sie alles Mögliche. Arrays untereinander, Dictionaries, Null mit Empty etc.

Definitionen

Beispiele

Einfache Werte vergleichen

'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

Arrays vergleichen

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,4),2)
<Variant()>  (
    [0] => <Integer> 1
    [1] => <Integer> 2
    [2] => <Integer> 2
    [3] => <Variant()>  (
        [0] => <Integer> 4
        [1] => <Integer> 5
    )
)
<Variant()>  (
    [0] => <Integer> 2
    [1] => <Integer> 1
    [2] => <Variant()>  (
        [0] => <Integer> 5
        [1] => <Integer> 4
    )
    [3] => <Integer> 2
)
 
'Normalverlgeich. Es wird Index und Value verglichen
? compaire(array(1,2,2,array(4,5)), array(2,1,array(5,4),2))
False
 
'Nur ValueVergleich
? compaire(array(1,2,2,array(4,5)), array(2,1,array(5,4),2),cpArrayValuesOnly)
True
 
'Analog zu den ersten Beispielen, ein Vergleich inkl. Typenvergleich und ohne
'Der erste Array Hat Strings anstelle von Integers
'Ohne Typenvergleich
? compaire(array("1","2","2",array(4,5)), array(2,1,array(5,4),2), cpArrayValuesOnly)
True
 
'Mit Typenvergleich
? compaire(array("1","2","2",array(4,5)), array(2,1,array(5,4),2), cpArrayValuesOnly+cpVarTypeStrong)
False

Dictionaries vergleichen

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

Code

udf_compaire.bas
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.0
'Name         : compaire
'Author       : Stefan Erb (ERS)
'History      : 12.09.2014 - ERS - Creation
'-------------------------------------------------------------------------------
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
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
 
    '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 IsArray(iVar1) And IsArray(iVar2) Then
        compaire = LBound(iVar1) = LBound(iVar2) And UBound(iVar1) = UBound(iVar2)
        If compaire Then
            Dim i As Integer: For i = LBound(iVar1) To UBound(iVar1)
                compaire = compaire(iVar1(i), iVar2(i), iParams)
                If Not compaire Then Exit Function
            Next i
        End If
    '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
                Dim k As Integer: 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.0
' * @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 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
vba/functions/compaire.1410858885.txt.gz · Last modified: 16.09.2014 11:14:45 by yaslaw