This is an old revision of the document!
Download cast_todblgeneric.bas (V-1.4.0)
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.
Public Function toDblGeneric( _ Optional ByVal iNumberV As Variant = Null, _ Optional ByVal iDelemiterHandling As tngDelemiterHandling = tngDecimal _ ) As Double
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
Die Zahl als Double
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
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