This is an old revision of the document!
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.
[VBA] print_r() wird nur für die Beispiele gebraucht. Diese Funktion wird im Einsatz nicht gebraucht
Public Function toDblGeneric( _ Optional ByVal iNumberV As Variant = Null, _ Optional ByVal iDelemiterHandling As tngDelemiterHandling = tngDecimal, _ Optional iClearCache As Boolean = False _ ) 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
'------------------------------------------------------------------------------- 'File : toDoubleGeneric ' Copyright mpl by ERB software ' http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/toDoubleGeneric 'Environment : VBA 2007 + 'Version : 1.2 'Author : Stefan Erb (ERS) 'History : 15.01.2014 - ERS - Creation ' : 11.02.2014 - ERS - Neu wird auch eine Nummer aus einem Text gefiltert. ' : 14.02.2014 - ERS - Den Parameter iDelemiterHandling hinzugefügt '------------------------------------------------------------------------------- Option Explicit '/** ' * 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 und Punkt '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_PATTERN = "^([-\+]?)\s*(\d+(?:([,\.])\d{3}([',\.])\d+|([,\.])\d{1,3}()|)[\d',\.]*)\s*([-\+]?)$" Private Const C_TODBLG_PATTERN = "^([{$sign}]?)\s*(\d+(?:([{$decimal}])\d{3}([{$thousend}])\d+|([{$decimal}])\d{1,3}()|)[\d{$thousend}]*)\s*([{$sign}]?)$" 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 Private Const C_TODBLG_ERR_NR = 13 'Err 13: Type missmatch Private Const C_TODBLG_EXTRACT_NUMBER_PATTERN = "([{$sign}]?[\s]*[{$thousend}{$decimal}\d]+[\s]*[{$sign}]?)" '/** ' * Cache. Gweisse informationen müssen nur einme gesetzt werden ' */ Private strRx As Object 'Cached RegEx um die erste Nummer aus einem String zu lösen Private dhRx As Object 'Cached RegEx um das Delemiterhändling im Spezialfall 1.234 zu handhaben Private toDblGRx As Object 'Cached RegEx Private strPattern As String 'Cache the Pattern Private toDblGPattern As String 'Cache the Pattern '/** ' * 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 ' * @param Boolean Flag um den Cache neu aufzubauen. Ist mehr in der Programmierphase interessant, wenn man an dem Pattern herumspielt ' * @return Double '*/ Public Function toDblGeneric( _ Optional ByVal iNumberV As Variant = Null, _ Optional ByVal iDelemiterHandling As tngDelemiterHandling = tngDecimal, _ Optional iClearCache As Boolean = False _ ) As Double Dim numberV As Variant: numberV = iNumberV Dim mc As Object Dim parts As Object On Error GoTo Err_Handler 'Den endgültigen Pattern zusammensetzen If _ Nz(toDblGPattern, Empty) = Empty _ Or Nz(strPattern, Empty) = Empty _ Or iClearCache _ Then toDblGPattern = replace(C_TODBLG_PATTERN, "{$decimal}", C_TODBLG_DECIMAL_PATTERNS) toDblGPattern = replace(toDblGPattern, "{$thousend}", C_TODBLG_THOUSEND_PATTERNS) toDblGPattern = replace(toDblGPattern, "{$sign}", C_TODBLG_SIGN_PATTERNS) strPattern = replace(C_TODBLG_EXTRACT_NUMBER_PATTERN, "{$decimal}", C_TODBLG_DECIMAL_PATTERNS) strPattern = replace(strPattern, "{$thousend}", C_TODBLG_THOUSEND_PATTERNS) strPattern = replace(strPattern, "{$sign}", C_TODBLG_SIGN_PATTERNS) End If 'Den Zahlenblock aus dem numberV extrahieren If strRx Is Nothing Or iClearCache Then Set strRx = CreateObject("VBScript.RegExp") strRx.pattern = strPattern End If If strRx.test(Nz(numberV)) Then Set mc = strRx.execute(numberV) numberV = mc.item(0).SubMatches(0) End If 'Das RegEx Object initialiseren If toDblGRx Is Nothing Or iClearCache Then Set toDblGRx = CreateObject("VBScript.RegExp") toDblGRx.pattern = toDblGPattern End If 'Den String umdrehen. IIIf() anstelle von Nz(), damit es auch in Excel funktioniert Dim numS As String: numS = StrReverse(IIf(IsNull(numberV) Or numberV = Empty, 0, numberV)) 'Prüfen, ob der string überhaubt greift If Not toDblGRx.test(numS) Then Err.Raise (C_TODBLG_ERR_NR) 'Den String umdrehen und aufteilen Set mc = toDblGRx.execute(numS) 'Die einzelnen Teile auslesen Set parts = mc.item(0).SubMatches 'Parts des Patterns '0: Vorzeichen danach '1: Ganze Zahl, ohne Vorzeichen '2: Dezimaltrennzeichen (Im Fall, dass Tausendertrennzeichen vorhanden sind) '3: Tausendertrennzeichen '4: Dezimaltrennzeichen (Im Fall, dass keine Tausendertrennzeichen vorhanden sind) '5: dummy (Damit im (?:..) kein Reihenfolgechaos ensteht '6: Vorzeichen davor 'Dezimaltrennzeichen ermitteln. Entweder in part 2 oder 4 Dim decimalSep As String: decimalSep = parts(2) & parts(4) 'Tausenderzeichen ermitteln Dim thousendSep As String: thousendSep = parts(3) 'Vorzeichen ermitteln. Davor der danach. Dim sign As String: sign = parts(0) & parts(6) If dhRx Is Nothing Then Set dhRx = CreateObject("VBScript.RegExp") dhRx.pattern = "^\d{3}\.\d{1,3}$" End If '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(parts(1)) _ Then 'Trennzeichen entfernen numS = replace(parts(1), IIf(thousendSep = Empty, decimalSep, thousendSep), vbNullString) Else 'Dezmaltrennzeichen markieren numS = replace(parts(1), 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, "."))) Exit_Handler: Set parts = Nothing Set mc = Nothing Exit Function Err_Handler: Set parts = Nothing Set mc = Nothing 'Err 13: Type missmatch Call Err.Raise(C_TODBLG_ERR_NR, "toDblGeneric", "Type missmatch" & vbCrLf & vbCrLf & "'" & iNumberV & "' is not a valid Number", Err.helpFile, Err.helpContext) Resume End Function