cast_todblgeneric.bas

Dies ist eine flexible Cast-Funktion um Strings mit verschiedenen Anordnungen von Tausender- und Dezimaltrennzeichen in ein Double zu wandeln.

Bei mir waren das vor allem Export aus SAP, die im folgenden Format vorlagen: 1.234.567,89-
In einem anderen File lag dann die Zahl wieder so vor: -1'234'567.89
Diese Funktion erkennt beide Formate.

Im Gegensatz zu [VBA] strToDouble() werden in dieser Funktion die Trennzeichen nicht definiert. Siehe dazu auch den Vergleich mit anderen Cast-Funktionen für Double.

[VBA] print_r() wird nur für die Beispiele gebraucht. Diese Funktion wird im Einsatz nicht gebraucht

Public Function toDblGeneric( _
        Optional ByVal iNumberV As Variant = Null, _
        Optional ByVal iDelemiterHandling As tngDelemiterHandling = tngDecimal, _
        Optional iClearCache As Boolean = False _
) As Double

• iNumberV String oder Nummer, welche gecasted werden soll
• iDelemiterHandling tngDelemiterHandling handelt das verhalten beim Speziealfall 1.234
• iClearCache lag um den Cache neu aufzubauen. Ist mehr in der Programmierphase interessant, wenn man an dem Pattern herumspielt

Dieser Enumerator regelt das Verhalten, wenn nicht klar ist ob es sich beim einzigen Trennzeichenfund um ein Dezimal- oder Tausendertrennzeichen handelt.
Zum Beispiel die Zahl 1,234. Das kann jetzt 1'234 oder 1.234 bedeuten.

Public Enum tngDelemiterHandling
    tngDecimal = 0
    tngThousend = 1
End Enum

• tngDecimal Beim Trennzeichen handelt es sich um ein Dezimaltrennzeichen (Standart)
• tngThousend Beim Trennzeichen handelt es sich um ein Tausendertrennzeichen

Die Zahl als Double

• Wenn iNumberV nicht geparst werden kann, wird ein Error 13 (Type missmatch) geworfen.
• Wenn die Zahl Tausnedertrennziechen aber keine Nachkommastellen hat, kommt ein falsches Resultat. Siehe Anwendungsbeispiele

Hier einige Anwendungsbeispiele

Für die Ausgabe der Resultate verwendete ich die Funktion [VBA] print_r().

'Eine ganze normale Zahl
print_r toDblGeneric("1234567.89")
<Double> 1234567.89
 
'Mit Tausendertrennzeichen
print_r toDblGeneric("-1'234'567.89")
<Double> -1234567.89
 
'In meinem idiotischen Forma aus SAP
print_r toDblGeneric("1.234.567,89-")
<Double> -1234567.89
 
'Zahl mit Nachkommastellen, jedoch ohne Nachkommastelle
print_r toDblGeneric("1'234.00")
<Double> 1234
 
'die Erste Zahl aus einem Text extrahieren
print_r toDblGeneric("Total-Summe: -1'234'567.89€ bei Anzahlung in 12 Raten")
<Double> -1234567.89
 
'Hat man Tausendertrennzeichen und keine Nachkommastellen, dann gibt die Funktion den Wert falsch aus.
'Leider kann da die Funktion nicht herausfinden ob das Komma ein Dezimal oder Tausendertrennzeichen ist.
print_r toDblGeneric("1,234")
<Double> 1.234
'Mann kann das übersteuern
print_r toDblGeneric("1,234", tngThousend)
<Double> 1234
'Wenn aber die Bedinungen für den Sonderfall nicht gegebnsind, dann wird trotz tngThousend normal gerechnet
print_r toDblGeneric("1,2345", tngThousend)
<Double> 1.2345
print_r toDblGeneric("1234,567", tngThousend)
<Double> 1234.567
print_r toDblGeneric("1,234,567", tngDecimal)
<Double> 1234567

cast_toDoubleGeneric.bas

'-------------------------------------------------------------------------------
'File         : toDoubleGeneric
'               Copyright mpl by ERB software
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/toDoubleGeneric
'Environment  : VBA 2007 +
'Version      : 1.2
'Author       : Stefan Erb (ERS)
'History      : 15.01.2014 - ERS - Creation
'             : 11.02.2014 - ERS - Neu wird auch eine Nummer aus einem Text gefiltert.
'             : 14.02.2014 - ERS - Den Parameter iDelemiterHandling hinzugefügt
'-------------------------------------------------------------------------------
Option Explicit
 
 
'/**
' * steuert das verhalten, wenn nicht klar ist, ob das letzte Zeichen ein Dezimaltrennzeichen oder ein Tausendertrennzeichen ist
' */
Public Enum tngDelemiterHandling
    tngDecimal = 0                  'Der Text 1,234 wird als 1.234 zurückgegeben
    tngThousend = 1                 'Der Text 1,234 wird als 1234 zurückgegeben
End Enum
 
 
'/**
' * User-Konstanten. Diese können für weitere Fälle ergänzt werden
' */
'Alle möglichen Tausendertrennzeichen als Regulärer Ausdruck
Private Const C_TODBLG_THOUSEND_PATTERNS = "`´',\."   'alle möglichen Hockommas, Komma und Punkt
'Alle möglichen Dezimaltrennzeichen als Regulärer Ausdruck
Private Const C_TODBLG_DECIMAL_PATTERNS = ",\."     'Komma und Punkt
'Alle möglichen Vorzeichen als Regulärer AUsdruck
Private Const C_TODBLG_SIGN_PATTERNS = "-\+"        'Plus und Minus
 
'/**
' * Fixe Konstanten. Diese sollten nicht verandert werden
' */
'Private Const C_TODBLG_PATTERN = "^([-\+]?)\s*(\d+(?:([,\.])\d{3}([',\.])\d+|([,\.])\d{1,3}()|)[\d',\.]*)\s*([-\+]?)$"
Private Const C_TODBLG_PATTERN = "^([{$sign}]?)\s*(\d+(?:([{$decimal}])\d{3}([{$thousend}])\d+|([{$decimal}])\d{1,3}()|)[\d{$thousend}]*)\s*([{$sign}]?)$"
Private Const C_TODBLG_DECIMAL_PLACEHOLDER = "#DEC#"    'Temporäres Decimaltrennzeichen, dass gesetzt wird. Muss einfach eindeutig sein und darf keines der Tausender- und Dezimatrennzeichen sein
Private Const C_TODBLG_ERR_NR = 13                      'Err 13: Type missmatch
Private Const C_TODBLG_EXTRACT_NUMBER_PATTERN = "([{$sign}]?[\s]*[{$thousend}{$decimal}\d]+[\s]*[{$sign}]?)"
 
'/**
' * Cache. Gweisse informationen müssen nur einme gesetzt werden
' */
Private strRx       As Object   'Cached RegEx um die erste Nummer aus einem String zu lösen
Private dhRx        As Object   'Cached RegEx um das Delemiterhändling im Spezialfall 1.234 zu handhaben
Private toDblGRx    As Object   'Cached RegEx
Private strPattern      As String   'Cache the Pattern
Private toDblGPattern   As String   'Cache the Pattern
 
'/**
' * Wandelt einen String in ein Double um, ohne genaue defnitionen
' * Mögliche Tausendertrennzeichen: ` ´ ' , . keines
' * Mögliche Dezimaltrennzeichen: , . keines
' * Mögliche Vorzeichen vor oder nach der Zahl, mit oder ohne Leerzeichen dazwischen: + - keines
' * @param  Variant     Input
' * @param  tngDelemiterHandling
' *                     Es gibt den Sonderfall '3.456'. Ist das jetzt 3456 oder 3,456. Mit tngDecima wird daraus 3.456, mit tngThosend 3456
' * @param  Boolean     Flag um den Cache neu aufzubauen. Ist mehr in der Programmierphase interessant, wenn man an dem Pattern herumspielt
' * @return Double
'*/
Public Function toDblGeneric( _
        Optional ByVal iNumberV As Variant = Null, _
        Optional ByVal iDelemiterHandling As tngDelemiterHandling = tngDecimal, _
        Optional iClearCache As Boolean = False _
) As Double
    Dim numberV As Variant: numberV = iNumberV
    Dim mc          As Object
    Dim parts       As Object
On Error GoTo Err_Handler
 
    'Den endgültigen Pattern zusammensetzen
    If _
            Nz(toDblGPattern, Empty) = Empty _
            Or Nz(strPattern, Empty) = Empty _
            Or iClearCache _
    Then
        toDblGPattern = replace(C_TODBLG_PATTERN, "{$decimal}", C_TODBLG_DECIMAL_PATTERNS)
        toDblGPattern = replace(toDblGPattern, "{$thousend}", C_TODBLG_THOUSEND_PATTERNS)
        toDblGPattern = replace(toDblGPattern, "{$sign}", C_TODBLG_SIGN_PATTERNS)
        strPattern = replace(C_TODBLG_EXTRACT_NUMBER_PATTERN, "{$decimal}", C_TODBLG_DECIMAL_PATTERNS)
        strPattern = replace(strPattern, "{$thousend}", C_TODBLG_THOUSEND_PATTERNS)
        strPattern = replace(strPattern, "{$sign}", C_TODBLG_SIGN_PATTERNS)
    End If
 
    'Den Zahlenblock aus dem numberV extrahieren
    If strRx Is Nothing Or iClearCache Then
        Set strRx = CreateObject("VBScript.RegExp")
        strRx.pattern = strPattern
    End If
    If strRx.test(Nz(numberV)) Then
        Set mc = strRx.execute(numberV)
        numberV = mc.item(0).SubMatches(0)
    End If
 
    'Das RegEx Object initialiseren
    If toDblGRx Is Nothing Or iClearCache Then
        Set toDblGRx = CreateObject("VBScript.RegExp")
        toDblGRx.pattern = toDblGPattern
    End If
 
    'Den String umdrehen. IIIf() anstelle von Nz(), damit es auch in Excel funktioniert
    Dim numS        As String:      numS = StrReverse(IIf(IsNull(numberV) Or numberV = Empty, 0, numberV))
    'Prüfen, ob der string überhaubt greift
    If Not toDblGRx.test(numS) Then Err.Raise (C_TODBLG_ERR_NR)
 
    'Den String umdrehen und aufteilen
    Set mc = toDblGRx.execute(numS)
 
    'Die einzelnen Teile auslesen
    Set parts = mc.item(0).SubMatches
    'Parts des Patterns
    '0: Vorzeichen danach
    '1: Ganze Zahl, ohne Vorzeichen
    '2: Dezimaltrennzeichen (Im Fall, dass Tausendertrennzeichen vorhanden sind)
    '3: Tausendertrennzeichen
    '4: Dezimaltrennzeichen (Im Fall, dass keine Tausendertrennzeichen vorhanden sind)
    '5: dummy (Damit im (?:..) kein  Reihenfolgechaos ensteht
    '6: Vorzeichen davor
 
    'Dezimaltrennzeichen ermitteln. Entweder in part 2 oder 4
    Dim decimalSep  As String:      decimalSep = parts(2) & parts(4)
 
    'Tausenderzeichen ermitteln
    Dim thousendSep As String:      thousendSep = parts(3)
 
    'Vorzeichen ermitteln. Davor der danach.
    Dim sign        As String:      sign = parts(0) & parts(6)
 
    If dhRx Is Nothing Then
        Set dhRx = CreateObject("VBScript.RegExp")
        dhRx.pattern = "^\d{3}\.\d{1,3}$"
    End If
    'Prüfen, ob es sich um eine Zahl ohne Nachkommastellen handelt
    '- Kein Tausendertrennzeiche, Dezimaltrennzeichen vorhanden, Delimiterhändling = Tausender, hat nach dem Trennzeichen 3 Stellen, hat vor dem Trennzeichen höchstens 3 Stellen
    '- Das Dezimaltrennzeichen ist mit dem Tausnedertrennzeichen identisch, hat nach dem Trennzeichen 3 Stellen, hat vor dem Trennzeichen höchstens 3 Stellen
    If _
            (( _
                thousendSep = Empty _
                And decimalSep <> Empty _
                And iDelemiterHandling = tngThousend _
            ) Or ( _
                decimalSep = thousendSep _
            )) _
            And dhRx.test(parts(1)) _
    Then
        'Trennzeichen entfernen
        numS = replace(parts(1), IIf(thousendSep = Empty, decimalSep, thousendSep), vbNullString)
    Else
        'Dezmaltrennzeichen markieren
        numS = replace(parts(1), decimalSep, C_TODBLG_DECIMAL_PLACEHOLDER, , 1)
        'Tausendertrennzeichen entfernen
        numS = replace(numS, thousendSep, vbNullString)
    End If
 
    'Markierung des Dezimaltrennzeichens durch einen . ersetzen und das Vorzeichen mitgeben
    toDblGeneric = CDbl(sign & StrReverse(replace(numS, C_TODBLG_DECIMAL_PLACEHOLDER, ".")))
 
Exit_Handler:
    Set parts = Nothing
    Set mc = Nothing
    Exit Function
Err_Handler:
    Set parts = Nothing
    Set mc = Nothing
    'Err 13: Type missmatch
    Call Err.Raise(C_TODBLG_ERR_NR, "toDblGeneric", "Type missmatch" & vbCrLf & vbCrLf & "'" & iNumberV & "' is not a valid Number", Err.helpFile, Err.helpContext)
    Resume
End Function