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

Download cast_todblgeneric.bas (V-1.3.3)

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.

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

• iNumberV String oder Nummer, welche gecasted werden soll
• iDelemiterHandling tngDelemiterHandling handelt das verhalten beim Speziealfall 1.234

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_todblgeneric.bas

Attribute VB_Name = "cast_toDblGeneric"
'-------------------------------------------------------------------------------
'File         : cast_toDblGeneric.bas
'               Copyright mpl by ERB software
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/toDoubleGeneric
'Environment  : VBA 2007 +
'Version      : 1.4.0
'Author       : Stefan Erb (ERS)
'History      : 15.01.2014 - ERS - Creation
'               ...
'               03.11.2014 - ERS - Für Frankreich das Leerzeichen als Tausender zulassen
'                                  NZ für Ecel mit bedinget Kompilierung hinzugfügt
'               03.12.2014 - ERS - cRegExp() durch cRx() ersetzt
'               14.11.2016 - ERS - Doe Potenzen hinzugefügt:  toDblGeneric("2.3 e-2") -> 0.023
'-------------------------------------------------------------------------------
Option Explicit
 
'Für Excel muss NZ() noch definert werden
'Darum hier angeben mit was dass die FUnktion läuft: "EXCEL"/"ACCESS"
'#Const prog = "EXCEL"
#Const prog = "ACCESS"
 
'   double = toDblGeneric(input [,delemiterHandling])
 
'/**
' * 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, Punkt und Leerzeichen
'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_DECIMAL_PLACEHOLDER = "#DEC#"    'Temporäres Decimaltrennzeichen, dass gesetzt wird. Muss einfach eindeutig sein und darf keines der Tausender- und Dezimatrennzeichen sein
 
'/**
' * 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
' * @return Double
'*/
Public Function toDblGeneric( _
        Optional ByVal iNumberV As Variant = Null, _
        Optional ByVal iDelemiterHandling As tngDelemiterHandling = tngDecimal _
) As Double
    Dim numberV As Variant: numberV = iNumberV
    Dim parts       As Object
On Error GoTo Err_Handler
 
    'Nummer aus Text extrahieren
    If strRx.test(NZ(numberV)) Then numberV = strRx.execute(numberV).item(0).subMatches(0)
 
    'Den String umdrehen.
    Dim numS        As String:      numS = StrReverse(IIf(NZ(numberV) = Empty, 0, numberV))
    'Prüfen, ob der string überhaubt greift
    If Not toDblGRx.test(numS) Then Err.Raise (13)  'Type Missmatch
 
    'Die einzelnen Teile auslesen
    Dim sign As String * 1, potenz As String, absNum As String, decimalSep As String, thousendSep As String, decimalSep2 As String, sign2 As String * 1
    'Patternauswertung:
    '0: Vorzeichen danach
    '1: E-Wert
    '2: Ganze Zahl, ohne Vorzeichen
    '3: Dezimaltrennzeichen (Im Fall, dass Tausendertrennzeichen vorhanden sind)
    '4: Tausendertrennzeichen
    '5: Dezimaltrennzeichen (Im Fall, dass keine Tausendertrennzeichen vorhanden sind)
    '6: dummy (Damit im (?:..) kein  Reihenfolgechaos ensteht
    '7: Vorzeichen davor
    list toDblGRx.execute(numS).item(0), sign, potenz, absNum, decimalSep, thousendSep, decimalSep2, , sign2
    'Dezimaltrennzeichen ermitteln. Entweder in part 2 oder 4
    decimalSep = Trim(decimalSep & decimalSep2)
    'Vorzeichen ermitteln. Davor oder danach.
    sign = Trim(sign2 & sign)
 
    '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(absNum) _
    Then
        'Trennzeichen entfernen
        numS = replace(absNum, IIf(thousendSep = Empty, decimalSep, thousendSep), vbNullString)
    Else
        'Dezmaltrennzeichen markieren
        numS = replace(absNum, 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, ".")) & StrReverse(potenz))
 
Exit_Handler:
    Set parts = Nothing
    Exit Function
Err_Handler:
    Set parts = Nothing
    'Err 13: Type missmatch
    Call Err.Raise(13, "toDblGeneric", "Type missmatch" & vbCrLf & vbCrLf & "'" & iNumberV & "' is not a valid Number", Err.HelpFile, Err.HelpContext)
    Resume
End Function
 
'-------------------------------------------------------------------------------
'--- PRIVATE PROPERTIES
'-------------------------------------------------------------------------------
' Patterns:
' {$T}: C_TODBLG_THOUSEND_PATTERNS  alle möglichen Hockommas, Komma, Punkt und Leerzeichen
' {$D}: C_TODBLG_DECIMAL_PATTERNS   Komma und Punkt
' {$S}: C_TODBLG_SIGN_PATTERNS      Plus und Minus
'/**
' * RegEx um die erste Nummer aus einem String zu lösen
' * @return RegExp
' */
Private Property Get strRx() As Object
    Static rx As Object:    If rx Is Nothing Then Set rx = cRx(cPattern("/([{$S}]?[\s]*[{$T}{$D}\d]+\s*(?:E[+-]?\d+)?[\s]*[{$S}]?)/i"))
    Set strRx = rx
End Property
 
'/**
' * RegEx um das Delemiterhändling im Spezialfall 1.234 zu handhaben
' * @return RegExp
' */
Private Property Get toDblGRx() As Object
    Static rx As Object:    If rx Is Nothing Then Set rx = cRx(cPattern("/^([{$S}]?)\s*(\d+[+-]?E)?\s*(\d+(?:([{$D}])\d{3}([{$T}])\d+|([{$D}])\d{1,3}()|)[\d{$T}]*)\s*([{$S}]?)$/i"))
    Set toDblGRx = rx
End Property
 
'/**
' * RegEx um den Sonderfall zu ermitteln
' * @return RegExp
' */
Private Property Get dhRx() As Object
    Static rx As Object:    If rx Is Nothing Then Set rx = cRx(cPattern("/^\d{3}[{$D}]\d{1,3}$/"))
    Set dhRx = rx
End Property
 
'-------------------------------------------------------------------------------
'--- PRIVATE FUNCTIONS
'-------------------------------------------------------------------------------
'/**
' * Stellt ein Patterns anhand der Settings zusammen
' * @param  String
' * @return String
' */
Private Function cPattern(ByVal iPattern As String) As String
    cPattern = replace(iPattern, "{$D}", C_TODBLG_DECIMAL_PATTERNS)
    cPattern = replace(cPattern, "{$T}", C_TODBLG_THOUSEND_PATTERNS)
    cPattern = replace(cPattern, "{$S}", C_TODBLG_SIGN_PATTERNS)
End Function
 
'-------------------------------------------------------------------------------
'--- LIBRARIES
'-------------------------------------------------------------------------------
 
'/**
' * 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
 
'/**
' * Dito zu List. Aber die Argumente ist ein vordimensionierter Array
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/list
' * V1.0.1 (gekürzte Version)
' * @param  Liste           Array, Dictionary, Collection, Regexp.MatchCollection, Regexp.Match oder DAO.Recordset
' * @param  Array<Varaint>  Auflistung der Variablen, die abgefüllt werden
' * @return Boolean         Angabe, ob die ganze Sache gültig war
' */
 
Private Function list( _
        ByRef iList As Variant, _
        ParamArray oParams() As Variant _
) As Boolean
    Dim uBnd    As Long:    uBnd = UBound(oParams)
    list = iList.subMatches.count > 0:     If Not list Then Exit Function
    If uBnd > iList.subMatches.count - 1 Then uBnd = iList.subMatches.count - 1
    Dim i As Integer: For i = 0 To uBnd
        If Not IsMissing(oParams(i)) Then oParams(i) = iList.subMatches(i)
    Next i
End Function
 
 
 
#If prog = "EXCEL" Then
    Private Function NZ(ByRef iValue As Variant, Optional ByRef iDefault As Variant = Empty) As Variant
        If IsNull(iValue) Then
            NZ = iDefault
        Else
            NZ = iValue
        End If
    End Function
#End If