Funktion um einen String in ein Double zu wandeln unter angabe von Tasuender- und Dezimaltrennzeichen.

Download cast_strtodouble.bas (V-2.0.0)

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.

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
    stdNoCache = 2 ^ 3          'Funktion wird nicht mit gecachten Formaten verarbeitet
End Enum

Die Zahl als Double

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

Hier einige Anwendungsbeispiele

'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

cast_strtodouble.bas

Attribute VB_Name = "cast_strToDouble"
'-------------------------------------------------------------------------------
'File         : cast_strToDouble.bas
'               Copyright mpl by ERB software
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/strtodate
'Environment  : VBA 2007 +
'Version      : 2.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
'               14.09.2015 - ERS - Alle fremden Methoden entfernt
'-------------------------------------------------------------------------------
Option Explicit
 
Public Enum stdStrToDoubleFLags
    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
    stdNoCache = 2 ^ 3          'Funktion wird nicht mit gecachten Formaten verarbeitet
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 pThousandSeparator      As String               'Cached Aktuelles Tausendertrennzeichen
Private pDecimalSeparator       As String               'Cached Aktuelles Dezimaltrennzeichen
Private pFlags                  As stdStrToDoubleFLags  'Cached Aktuelles Vorzeichenposition
Private pReset                  As Boolean
 
'/**
' * 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 String = Empty, _
        Optional ByVal iDecimalSeperator As String = Empty, _
        Optional ByVal iFlags As stdStrToDoubleFLags = stdSignRight + stdSignLeft _
) As Double
    Dim numberS             As String   'Nummerstring während der verarbeitung
 
    'Wenn sich das Dezimalzeichen oder die FLags ändern, Patterns neu herleiten
    pReset = CStr(iDecimalSeperator) <> pDecimalSeparator _
            Or CStr(iThousandSeparator) <> pThousandSeparator _
            Or iFlags <> pFlags _
            Or (iFlags And stdNoCache) = stdNoCache
 
    If pReset Then
        thousandSeparator = iThousandSeparator
        decimalSeparator = iDecimalSeperator
        pFlags = iFlags
    End If
 
    'Die erste Patternübereinstimmung extrahieren und alle tausenderzeichen entfernen
    numberS = Replace(rxFormat.execute(iNumberS)(0).value, thousandSeparator, vbNullString)
    'Die parsen
    numberS = rxFormat.Replace(numberS, replacement)
 
    'Nur wenn Vorzeichen an beiden Edden möglich sind, das erste gefundene nehmen
    If signLeft And signRight Then numberS = rxToMatchSign.Replace(numberS, "$1")
 
    strToDouble = CDbl(numberS)
End Function
 
'/**
' * RegExp um die Zahl zu parsen
' * subMatches: 0) Vorzeichen Links 1) Ganze Zahl (inkl. Tausendertrennzeichen) 2) Nachkommastellen 3) Vorzeichen nach der Zahl
' * @return RegExp
' */
Private Property Get rxFormat() As Object
    Static pRxFormat As Object
    If pRxFormat Is Nothing Or pReset Then Set pRxFormat = cRx("/(" & IIf(signLeft, "[-\+]?", "") & ")([\d" & thousandSeparatorPattern & "]*)?(?:" & decimalSeparatorPattern & "(\d*))?(" & IIf(signRight, "[-\+]?", "") & ")/")
    Set rxFormat = pRxFormat
End Property
 
'/**
' * Erstellt den Ersetzungsstring für rxFormat
' * @return String
' */
Private Property Get replacement() As String
    Static pRepl As String
    If pReset Then
        If signLeft Then pRepl = "$1"
        If signRight Then pRepl = pRepl & "$4"
        pRepl = pRepl & "$2"
        pRepl = pRepl & userDecimalSeparator & "$3"
    End If
    replacement = pRepl
End Property
 
'/**
' * RegExp um doppelte Vorzeichen zu eliminieren
' * @return RegExp
' */
Private Property Get rxToMatchSign() As Object
    Static pRx As Object: If pRx Is Nothing Then Set pRx = cRx("/([-+])[-+]/")
    Set rxToMatchSign = pRx
End Property
 
 
'/**
' * Flag für Vorzeichen Links
' * @return Boolean
' */
Private Property Get signLeft() As Boolean
    Static pSign As Boolean: If pReset Then pSign = (pFlags And stdSignLeft) = stdSignLeft
    signLeft = pSign
End Property
 
'/**
' * Flag für Vorzeichen Rechts
' * @return Boolean
' */
Private Property Get signRight() As Boolean
    Static pSign As Boolean: If pReset Then pSign = (pFlags And stdSignRight) = stdSignRight
    signRight = pSign
End Property
 
 
 
'/**
' * Handelt die Tausendertrennzeichen
' * @return String
' */
Private Property Let thousandSeparator(ByVal iThousandSeparator As String)
    pThousandSeparator = iThousandSeparator
End Property
Private Property Get thousandSeparator() As String
    If pReset Then pThousandSeparator = IIf(pThousandSeparator = Empty, userThousandSeparator, pThousandSeparator)
    thousandSeparator = pThousandSeparator
End Property
 
'/**
' * Pattern für den Tausenderseperator
' * @return String
' */
Private Property Get thousandSeparatorPattern() As String
    Static pattern As String: If pReset Then pattern = rxEscapeString(thousandSeparator)
    thousandSeparatorPattern = pattern
End Property
'/**
' * Ermittelt das Userformat für das Tausendertrennzeichens aus den Settings
' * @return String
'*/
Private Property Get userThousandSeparator() As String
    Static separator As String
    If separator = Empty Or pReset Then
        Dim data As String * 10
        Dim ret As Long: ret = getLocaleInfo(GetUserDefaultLCID, LOCALE_STHOUSAND, data, 10)
        separator = Left$(data, ret - 1)
    End If
    userThousandSeparator = separator
End Property
 
'/**
' * handelt die Dezimaltrennzeichen
' * @return String
' */
Private Property Let decimalSeparator(ByVal iDecimalSeparator As String)
    pDecimalSeparator = iDecimalSeparator
End Property
Private Property Get decimalSeparator() As String
    If pReset Then pDecimalSeparator = IIf(pDecimalSeparator = Empty, userDecimalSeparator, pDecimalSeparator)
    decimalSeparator = pDecimalSeparator
End Property
 
'/**
' * Pattern für den Dezimalseperator
' * @return String
' */
Private Property Get decimalSeparatorPattern() As String
    Static pattern As String: If pReset Then pattern = rxEscapeString(decimalSeparator)
    decimalSeparatorPattern = pattern
End Property
 
'/**
' * Ermittelt das Userformat für das Dezimaltrennzeichen aus den Settings
' * @return Trennzeichen
'*/
Private Property Get userDecimalSeparator() As String
    Static separator As String
    If separator = Empty Or pReset Then
        Dim data As String * 10
        Dim ret As Long: ret = getLocaleInfo(GetUserDefaultLCID, LOCALE_SDECIMAL, data, 10)
        separator = Left$(data, ret - 1)
    End If
    userDecimalSeparator = separator
End Property
 
 
 
'/**
' * Dies ist die Minimalversion von cRegExp
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp#abgespeckte_version
' * mögliche Delemiter: @&!/~#=\|
' * mögliche Modifiers: g (Global), i (IgnoreCode, m (Mulitline)
' *
' * @example    myRx = cRx("/([a]{2,})/i") 'Finde alle folgen von a. Flag:IgnoreCase
' * @version    2.1.0 (01.12.2014)
' * @param      String      Pattern mit Delimiter und Modifier analog zu PHP
' * @return     Object      RegExp-Object
' */
Private Function cRx(ByVal iPattern As String) As Object
    Static rxP As Object:       Set cRx = CreateObject("VBScript.RegExp")
    If rxP Is Nothing Then:     Set rxP = CreateObject("VBScript.RegExp"): rxP.pattern = "^([@&!/~#=\|])?(.*)\1(?:([Ii])|([Gg])|([Mm]))*$"
    Dim sm As Object:           Set sm = rxP.execute(iPattern)(0).subMatches
    cRx.pattern = sm(1):        cRx.IgnoreCase = Not isEmpty(sm(2)):       cRx.Global = Not isEmpty(sm(3)):     cRx.Multiline = Not isEmpty(sm(4))
End Function
 
'/**
' * Escapte alle Sonderzeichen um eine rxFormat-Pattern zu erstellen
' *
' *     string = rxEscapeString(string)
' *
' * @example    rxEscapeString("Hallo Welt. Geht es dir (noch) gut?")
' *             Hallo Welt\. Geht es dir \(noch\) gut\?
' * @param  String
' * @return String
' */
Private Function rxEscapeString(ByVal iString As String) As String
    Static rx As Object: If rx Is Nothing Then Set rx = cRx("/([\\\*\+\?\|\{\[\(\)\^\$\.\#])/")
    rxEscapeString = rx.Replace(iString, "\$1")
End Function