cast_strtodouble.bas

Manchmal bekommt man Zahlen als Text in den wirrsten Formaten. Mit der Funktion strToDouble kann ich die meisten dieser Formate in in ein Double umwandeln.

Bei mir waren das vor allem Export aus SAP, die im folgenden Format vorlagen: 1.234.567,89-

Die meisten Variablen bleiben im Cache und werden nur überschrieben, wenn sie sich ändern. Somit muss nicht jedesmal alles durchgegangen werden. Das beschleunigt den Mehrfachaufruf zB. in einem Query

Im Gegensatz zu [VBA] toDoubleGeneric() werden in dieser Funktion die Trennzeichen klar definiert.

Die strToDouble -Funktion greift auf andere Funktionen zu, die ich bereits erstellt habe.

Für die Nummer-Cast-Funktionen verwende ich rx Funktionen aus [VBA] RegExp Functions mit Cache

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

Public Function strToDouble( _
        ByVal iNumberS As String, _
        Optional ByVal iThousandSeparator As Variant = Null, _
        Optional ByVal iDecimalSeperator As Variant = Null, _
        Optional ByVal iFlags As stdStrToDoubleFLags = stdSignRight + stdSignLeft _
) As Double

• iNumberS Die Zahl im Textformat
• iThousandSeparator Tausendertrennzeichen. Wenn Null, dann das Trennezichen aus den Usersettungs des System
• iDecimalSeperator Dezimaltrennzeichen. Wenn Null, dann das Trennezichen aus den Usersettungs des System
• iFlags Flags: Position des Vorzeichens, Angabe ob es Dezimalstellen hat. Siehe den Enumerator stdStrToDoubleFLags

Für die Position des Vorzeichens, wird der folgende Enumerator verwendet

Public Enum stdSignPosition
    stdNoSign = 2 ^ 0           'Die Zahl hat kein Vorzeichen oder schneidet es ab (analog zu abs())
    stdSignLeft = 2 ^ 1         'Das Vorzeichen ist auf der linken Seite, falls vorhanen
    stdSignRight = 2 ^ 2        'Das Vorzeichen ist auf der rechten Seite, falls vorhanen
    stdWithoutDecimal = 2 ^ 3   'Explizite Angabe, dass keine Dezimalzeichen vorhanden sind
End Enum

Die Zahl als Double

Hier einige Anwendungsbeispiele

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

'Mit User-Stnadarteinstellung des Systems
print_r strToDouble("1'234'567.89")
<Double> 1234567.89
 
print_r strToDouble("-1'234'567.89")
<Double> -1234567.89
 
'Minuszeichen am Ende
print_r strToDouble("1'234'567.89-")
<Double> -1234567.89
 
'Mit einem Komma als Tausendertrennzeichen
print_r strToDouble("1,234,567.89", ",")
<Double> 1234567.89
 
'So wie ich die Daten aus SAP bekommen: Punkt als Tasuender-, Komma als Dezimaltrennzeichen
'und das Vorzeichen am Ende
print_r strToDouble("1.234.567,89-", ".", ",", stdSignRight)
<Double> -1234567.89
 
'Positives Vorzeichen am Ende
print_r strToDouble("-1'234'567.89+")
<Double> -1234567.89
 
'Da mein System den Punkt als Dezimaltrennzeichen hat, sind in diesem Beispiel
'beide Trennzeichen identisch. Es wir automatisch das letzte als Dezimaltrennzeichen
'gewertet
print_r strToDouble("1.234.567.890", ".")
<Double> 1234567.89
'Mit stdWithoutDecimal kann ich das übersteuern
print_r strToDouble("1.234.567.890", ".", , stdWithoutDecimal)
<Double> 1234567890
'Oder ich überschreibe das Dezimaltrennzeichen mit etwas anderem, dann ists auch klar
print_r strToDouble("1.234.567.890", ".", ",")
<Double> 1234567890
'Wenn ich auch noch vorzeichen habe, so muss ich das bei stdWithoutDecimal zusätzlich angeben
print_r strToDouble("1.234.567.890-", ".", , stdWithoutDecimal + stdSignRight)
<Double> -1234567890
 
'Die Zahl kann auch aus einem Text extrahiert werden
print_r strToDouble("Saldo: 1'234'567.89- CHF")
<Double> -1234567.89
print_r strToDouble("Saldo: -1.234.567,89 CHF", ".", ",")
<Double> -1234567.89

strToDoubleModul.bas

'-------------------------------------------------------------------------------
'File         : strToDouble
'               Copyright mpl by ERB software
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/strtodate
'Environment  : VBA 2007 +
'Version      : 1.0
'Author       : Stefan Erb (ERS)
'History      : 07.01.2014 - ERS - Creation
'               14.01.2014 - ERS - Soweit umprogrammiert, dass möglichst viel gechached wird,
'                                  falls die Funktion in einem Query verwendet wird
'Requiered:     rx_escape_string()      http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/rx/rx_escape_string
'               rx_choose()             http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/rx/rx_choose
'               rx_replace()            http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/rx/rx_replace
'               Oder gleich das ganze rx_* Paket:   http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/rx/index
'-------------------------------------------------------------------------------
Option Explicit
 
Public Enum stdStrToDoubleFLags
    [_FIRST] = 0
    stdNoSign = 2 ^ 0           'Die Zahl hat kein Vorzeichen oder schneider es ab (analog zu abs())
    stdSignLeft = 2 ^ 1         'Das Vorzeichen ist auf der linken Seite, falls vorhanen
    stdSignRight = 2 ^ 2        'Das Vorzeichen ist auf der rechten Seite, falls vorhanen
    stdWithoutDecimal = 2 ^ 3   'Explizite Angabe, dass keine Dezimalzeichen vorhanden sind
    [_LAST] = 3
End Enum
 
'/**
' * API Funktionen um die Systemtrennzeichen zu ermitteln
' */
Private Declare Function GetLocaleInfo Lib "KERNEL32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long
Private Declare Function GetUserDefaultLCID Lib "KERNEL32" () As Long
Private Const LOCALE_SDECIMAL = &HE
Private Const LOCALE_STHOUSAND = &HF
 
'/**
' * Privtae Konstanten
'*/
Private Const C_SIGN_PATTERN = "([-\+]?)"               'RegEx Pattern für die Vorzeichen
'/**
' * Die Angaben des letzten Laufes werden gespeichert. So muss bei mehrmaligem Aufruf mit
' * denselben Parametern nicht mehr alles neu ermittelt werden
' */
Private userThousandSeparator   As String               'Cached Tausendertrennzeichen aus den Usersettings
Private thousandSeparator       As String               'Cached Aktuelles Tausendertrennzeichen
Private userDecimalSeparator    As String               'Cached Dezimaltrennzeichen au den Usersettings
Private decimalSeparator        As String               'Cached Aktuelles Dezimaltrennzeichen
Private decimalSeparatorPat     As String               'Cached Regex-Pattern für Dezimaltrennzeichen
Private flags                   As stdStrToDoubleFLags  'Cached Aktuelles Vorzeichenposition
Private parsePattern            As String               'Cached Vollständiges Pattern inkl. Vorzeichen
Private replacement             As String               'Cached Regex-Replacment
 
'/**
' * Konvertiert einen String in ein Double unter Anagabe der Trennzeichen und Vorzeichenposition
' * @param  String
' * @param  Variant         Tausendertrennzeichen. Wenn Null, dann das Trennezichen aus den Usersettungs des System
' * @param  Variant         Dezimaltrennzeichen. Wenn Null, dann das Trennezichen aus den Usersettungs des System
' * @param  stdStrToDoubleFLags Flags: Angabe über die Lage des VOrzeichens und ob keine Dezimalzeichen vorhanden sind. Ist Kombinierbar
' * @return Double
' * Errors:
' * 13          Der String lässt sich nicht in ein Double wandeln
' */
Public Function strToDouble( _
        ByVal iNumberS As String, _
        Optional ByVal iThousandSeparator As Variant = Null, _
        Optional ByVal iDecimalSeperator As Variant = Null, _
        Optional ByVal iFlags As stdStrToDoubleFLags = stdSignRight + stdSignLeft _
) As Double
    Dim numberS             As String   'Nummerstring während der verarbeitung
    Dim parts()             As String   'AUteiling Vorkomma, Nachkomma bei gleichen Separatoren
 
    'Tausendertrennzeichen aus Eingabe oder aus dem System auslesen
    If IsNull(iThousandSeparator) Then
        If userThousandSeparator = vbNullString Then userThousandSeparator = getUserThousandSeparator
        iThousandSeparator = userThousandSeparator
    End If
    If CStr(iThousandSeparator) <> thousandSeparator Then thousandSeparator = iThousandSeparator
 
    'Dezimaltrennzeichen aus Eingabe oder aus dem System auslesen
    If IsNull(iDecimalSeperator) Then
        If userDecimalSeparator = vbNullString Then userDecimalSeparator = getUserDecimalSeparator
        iDecimalSeperator = userDecimalSeparator
    End If
 
    'Wenn sich das Deziimalzeichen oder die FLags ändern, Patterns neu herleiten
    If _
            CStr(iDecimalSeperator) <> decimalSeparator _
            Or CInt(Nz(iFlags)) <> flags _
    Then
        'Eingaben übernhemen
        decimalSeparator = iDecimalSeperator
        flags = iFlags
        'Wandelt das Trennzeichen zu einem RegEx-Pattern  '.' -> '\.'
        decimalSeparatorPat = rx_escape_string(decimalSeparator)
        'RegEx Pattern für die Zahl zusammenstellen.
        parsePattern = "(\d+)" & decimalSeparatorPat & "?(\d*)"
        'Links oder Rechts den Pattern für das Vorzeichen anhängen
        If flags And stdNoSign Then
            'Kein Vorzeichen vorhanden
            replacement = "$1.$2"
        ElseIf (flags And (stdSignLeft + stdSignRight)) = (stdSignLeft + stdSignRight) Then
            'Vorzeichen kann Links oder Rechts vorkommen
            parsePattern = C_SIGN_PATTERN & "\s*" & parsePattern & C_SIGN_PATTERN
            replacement = "$1$4$2.$3"
        ElseIf flags And stdSignLeft Then
            'Vorzeichen kann nur Links vorkommen
            parsePattern = C_SIGN_PATTERN & "\s*" & parsePattern
            replacement = "$1$2.$3"
        ElseIf flags And stdSignRight Then
            'Vorzeichen kann nur Rechts vorkommen
            parsePattern = parsePattern & "\s*" & C_SIGN_PATTERN
            replacement = "$3$1.$2"
        Else
            'Vorzeichen nicht geregelt - ergo keine
            replacement = "$1.$2"
        End If
    End If
 
    If iFlags And stdWithoutDecimal Then
        'Keine Dezimaltrennung
        numberS = Replace(Replace(iNumberS, decimalSeparator, vbNullString), thousandSeparator, vbNullString)
    ElseIf decimalSeparator <> thousandSeparator Then
        'Dezimal- und Tausendertrennzeichen sind verschieden
        'Tausenderzeichen eliminieren:
        numberS = Replace(iNumberS, thousandSeparator, vbNullString)
    Else
        'Das Tausendertrennzeichen und das Dezimaltrennzeichen sind identisch. (ggf tausender nicht gesetzt)
        'Darum das letzte Zeichen als Dezimalzeichen werten
        'String umdrehen und nach dem ersten (also vorher letzten) Trennzeichen aufsplitten
        parts = Split(StrReverse(iNumberS), decimalSeparator, 2)
        'Erster Teil (Nachkommastellen) & Trennzeichen & Vorkommastellen mit entferneten Trennzeichen wieder zurückfrehen
        numberS = StrReverse(parts(0) & decimalSeparator & Replace(parts(1), thousandSeparator, vbNullString))
    End If
 
    'Die erste Patternübereinstimmung extrahieren
    numberS = rx_choose(parsePattern, numberS)
    'Und parsen
    numberS = rx_replace(parsePattern, replacement, numberS)
 
    'Nur wenn Vorzeichen an beiden Edden möglich sind, das erste gefundene nehmen
    If flags And (stdSignLeft + stdSignRight) Then numberS = rx_replace("([-+])[-+]", "$1", numberS)
 
    strToDouble = CDbl(numberS)
End Function
 
'/**
' * Leert den strToDouble-Cache
' * Wird nur bei der Entwicklung gebraucht
' */
Public Sub resetCacheStrToDouble()
    userThousandSeparator = Empty
    thousandSeparator = Empty
    userDecimalSeparator = Empty
    decimalSeparator = Empty
    decimalSeparatorPat = Empty
    flags = Empty
    parsePattern = Empty
    replacement = Empty
End Sub
 
'/**
' * Ermittelt das Userformat für das Dezimaltrennzeichen aus den Settings
' * @param  String  Wert, falls die Funktion fehlschlägt
' * @return Trennzeichen
'*/
Private Function getUserDecimalSeparator(Optional ByVal iDefault As String = ".") As String
    Dim Data As String * 10
    Dim ret As Long
    ret = GetLocaleInfo(GetUserDefaultLCID, LOCALE_SDECIMAL, Data, 10)
    getUserDecimalSeparator = IIf(ret > 0, Left$(Data, ret - 1), iDefault)
End Function
 
'/**
' * Ermittelt das Userformat für das Tausendertrennzeichen aus den Settings
' * @param  String  Wert, falls die Funktion fehlschlägt
' * @return Trennzeichen
'*/
Private Function getUserThousandSeparator(Optional ByVal iDefault As String = "'") As String
    Dim Data As String * 10
    Dim ret As Long
    ret = GetLocaleInfo(GetUserDefaultLCID, LOCALE_STHOUSAND, Data, 10)
    getUserThousandSeparator = IIf(ret > 0, Left$(Data, ret - 1), iDefault)
End Function