User Tools

Site Tools


vba:cast:todoublegeneric

[VBA] toDoubleGeneric()

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

Version 1.4.0 - 14.011.2016

Download cast_todblgeneric.bas (V-1.4.0)

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.

Definition

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

Parameterliste

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

Enumerator

tngDelemiterHandling

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

Rückgabewert

Die Zahl als Double

Errors

  • 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

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
 
'Mit dem E-Faktor
print_r toDblGeneric("2.3 e2")
<Double> 230

Vergleich mit anderen Cast-Funktionen für Double

cdbl() aus VBA castDbl() strToDouble() toDoubleGeneric()
Normale Zahl in ein Double wandeln ja ja ja ja
NULL/EMPTY zu 0 wandeln nein ja ja ja
Andere Trennzeichen zulasse nein nein ja ja
Flexibel auf Trennzeichen reagieren nein nein nein ja
Zahl aus Text extrahieren nein Auswählen welche Zahl im Text erste Zahl erste Zahl
Verhalten bei ungültiger Eingabe wirft ein Error 13 (Type missmatch) Gibt 0 zurück wirft ein Error 13 (Type missmatch) wirft ein Error 13 (Type missmatch)
Sicherheit, dass das Resultat stimmt sicher unsicher:
gibt 0 zurück und wirft kein Fehler
sicher unsicher:
Der Fall von 1-3 Vorkommastellen und genau 3 Nachkommastellen muss über einen Parameter definiert werden
Verwendungszweck Für vieles gut genug. Eignet sich nicht, wenn man die Zahl in einem komischen Format vorliegt Falls man alle möglichen Fehler bei cdbl() ignorieren will, eignet sich diese Funktion Wenn die Zahl in einem anderen bekannten Format vorliegt, ist dies die richtige Funktion Und diese ist geeignet, wenn die Zahl in irgend einem Format daherkommt und man nicht genau weiss in welchem
Download na na cast_strtodouble.bas cast_todblgeneric.bas

Code

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
 
 
 
 

Discussion

Enter your comment. Wiki syntax is allowed:
If you can't read the letters on the image, download this .wav file to get them read to you.
 
vba/cast/todoublegeneric.txt · Last modified: 14.11.2016 10:48:26 by yaslaw