“Always listen to experts. They’ll tell you what can’t be done and why. Then do it.” [Robert Heinlein]

## Abstract

Manchmal müssen Sie eine Zahl in Worten ausgeben mit Euro und Cent. 1,01 würde zum Beispiel als “Ein Euro und Ein Cent” ausgegeben. ## Appendix – Programmcode sbSpellNumber / sbInWorten

Bitte den Haftungsausschluss im Impressum beachten.

``````Private sNWord(0 To 28) As String
Private sHWord(1 To 4) As String

Function sbInWorten(ByVal sNumber As String) As String
sbInWorten = sbSpellNumber(sNumber, "German", "EUR")
End Function

Function sbSpellNumber(ByVal sNumber As String, _
Optional sLang As String = "English", _
Optional sCcy As String = "USD") As String
'Template was Microsoft's limited version:
'https://support.microsoft.com/de-de/help/213360/
'how-to-convert-a-numeric-value-into-english-words-in-excel
'This version informs the user about its limits.
'Source (EN): http://www.sulprobil.com/sbspellnumber_en/
'Source (DE): http://www.bplumhoff.de/sbinworten_de/
'(C) (P) by Bernd Plumhoff  02-Mar-2018 PB V1.0

Dim Euros As String, cents As String
Dim Result As String, Temp As String
Dim DecimalPlace As Integer, Count As Integer
Dim Place(1 To 6) As String
Dim dNumber As Double
Dim prefix As String, suffix As String

Select Case sLang
Case "English"
Place(1) = ""
Place(2) = " Thousand "
Place(3) = " Million "
Place(4) = " Billion "
Place(5) = " Trillion "
Place(6) = " Mantissa not wide enough for this number "
sHWord(1) = ">>>>> Error (Absolute amount > 999999999999999)! <<<<<"
sHWord(2) = " (rounded)"
sHWord(3) = "Minus "
sHWord(4) = "and"
sNWord(0) = "zero"
sNWord(1) = "one"
sNWord(2) = "two"
sNWord(3) = "three"
sNWord(4) = "four"
sNWord(5) = "five"
sNWord(6) = "six"
sNWord(7) = "seven"
sNWord(8) = "eight"
sNWord(9) = "nine"
sNWord(10) = "ten"
sNWord(11) = "eleven"
sNWord(12) = "twelve"
sNWord(13) = "thirteen"
sNWord(14) = "fourteen"
sNWord(15) = "fifteen"
sNWord(16) = "sixteen"
sNWord(17) = "seventeen"
sNWord(18) = "eighteen"
sNWord(19) = "nineteen"
sNWord(20) = "twenty"
sNWord(21) = "thirty"
sNWord(22) = "fourty"
sNWord(23) = "fifty"
sNWord(24) = "sixty"
sNWord(25) = "seventy"
sNWord(26) = "eighty"
sNWord(27) = "ninety"
sNWord(28) = "hundred"
Case "German"
Place(1) = ""
Place(2) = " Tausend "
Place(3) = " Millionen "
Place(4) = " Milliarden "
Place(5) = " Billionen "
Place(6) = " Die Mantisse ist nicht groß genug für diese Zahl "
sHWord(1) = ">>>>> Fehler (Absolutbetrag > 999999999999999)! <<<<<"
sHWord(2) = " (gerundet)"
sHWord(3) = "Minus "
sHWord(4) = "und"
sNWord(0) = "null"
sNWord(1) = "ein"
sNWord(2) = "zwei"
sNWord(3) = "drei"
sNWord(4) = "vier"
sNWord(5) = "fünf"
sNWord(6) = "sechs"
sNWord(7) = "sieben"
sNWord(8) = "acht"
sNWord(9) = "neun"
sNWord(10) = "zehn"
sNWord(11) = "elf"
sNWord(12) = "zwölf"
sNWord(13) = "dreizehn"
sNWord(14) = "vierzehn"
sNWord(15) = "fünfzehn"
sNWord(16) = "sechzehn"
sNWord(17) = "siebzehn"
sNWord(18) = "achtzehn"
sNWord(19) = "neunzehn"
sNWord(20) = "zwanzig"
sNWord(21) = "dreißig"
sNWord(22) = "vierzig"
sNWord(23) = "fünfzig"
sNWord(24) = "sechzig"
sNWord(25) = "siebzig"
sNWord(26) = "achtzig"
sNWord(27) = "neunzig"
sNWord(28) = "hundert"
End Select

'Empty string = 0
If "" = sNumber Then
sNumber = "0"
End If

dNumber = sNumber + 0#

'If we cannot cope with it, tell the user!
If Abs(dNumber) > 999999999999999# Then
sbSpellNumber = sHWord(1)
Exit Function
End If

'If we have to round we present a suffix "(rounded)"
If Abs(dNumber - Round(dNumber, 2)) > 1E-16 Then
dNumber = Round(dNumber, 2)
suffix = sHWord(2)
End If

'Negative numbers get a prefix "Minus"
If dNumber < 0# Then
prefix = sHWord(3)
dNumber = -dNumber
sNumber = Right(sNumber, Len(sNumber) - 1)
End If

sNumber = Trim(Str(sNumber))
If Left(sNumber, 1) = "." Then
sNumber = "0" & sNumber
End If

DecimalPlace = InStr(sNumber, ".")

If DecimalPlace > 0 Then
cents = GetTens(Left(Mid(sNumber, DecimalPlace + 1) & "00", 2), _
sLang, sCcy)
sNumber = Trim(Left(sNumber, DecimalPlace - 1))
End If

Count = 1
Do While sNumber <> ""
Temp = GetHundreds(Right(sNumber, 3), sLang, sCcy)
If Temp <> "" Then
If Euros <> "" And sLang = "German" Then
Euros = Temp & Place(Count) & " " & _
sHWord(4) & " " & Euros
Else
Euros = Temp & Place(Count) & Euros
End If
End If
If Len(sNumber) > 3 Then
sNumber = Left(sNumber, Len(sNumber) - 3)
Else
sNumber = ""
End If
Count = Count + 1
Loop

Select Case sCcy
Case "EUR"
Select Case Euros
Case ""
Euros = sNWord(0) & " Euros"
Case sNWord(1)
Euros = sNWord(1) & " Euro"
Case Else
Euros = Euros & " Euros"
End Select

Select Case cents
Case ""
cents = " " & sHWord(4) & " " & sNWord(0) & " Cents"
Case sNWord(1)
cents = " " & sHWord(4) & " " & sNWord(1) & " Cent"
Case Else
cents = " " & sHWord(4) & " " & cents & " Cents"
End Select
Case "GBP"
Select Case Euros
Case ""
Euros = sNWord(0) & " Pounds"
Case sNWord(1)
Euros = sNWord(1) & " Pound"
Case Else
Euros = Euros & " Pounds"
End Select

Select Case cents
Case ""
cents = " " & sHWord(4) & " " & sNWord(0) & " Pence"
Case sNWord(1)
cents = " " & sHWord(4) & " " & sNWord(1) & " Penny"
Case Else
cents = " " & sHWord(4) & " " & cents & " Pence"
End Select
Case "USD"
Select Case Euros
Case ""
Euros = sNWord(0) & " Dollars"
Case sNWord(1)
Euros = sNWord(1) & " Dollar"
Case Else
Euros = Euros & " Dollars"
End Select

Select Case cents
Case ""
cents = " " & sHWord(4) & " " & sNWord(0) & " Cents"
Case sNWord(1)
cents = " " & sHWord(4) & " " & sNWord(1) & " Cent"
Case Else
cents = " " & sHWord(4) & " " & cents & " Cents"
End Select
End Select

Temp = UCase(Replace(Euros & cents, "  ", " "))
Select Case sLang
Case "English"
Temp = Application.WorksheetFunction.Proper(Temp)
Temp = Replace(Temp, " And ", " and ")
Case "German"
Temp = Application.WorksheetFunction.Proper(Temp)
Temp = Replace(Temp, "Ein Millionen", "Eine Million")
Temp = Replace(Temp, "Ein Milliarden", "Eine Milliarde")
Temp = Replace(Temp, "Ein Billionen", "Eine Billion")
Temp = Replace(Temp, "Dollars", "Dollar")
Temp = Replace(Temp, "Cents", "Cent")
Temp = Replace(Temp, "Pounds", "Pfund")
Temp = Replace(Temp, "Pound", "Pfund")
Temp = Replace(Temp, "Euros", "Euro")
Temp = Replace(Temp, "Pence", "Pennies")
Temp = Replace(Temp, " Und ", " und ")
End Select

sbSpellNumber = prefix & Temp & suffix

End Function

Private Function GetHundreds(ByVal sNumber, _
Optional sLang As String = "English", _
Optional sCcy As String = "USD") As String
Dim Result As String

If Val(sNumber) = 0 Then Exit Function
sNumber = Right("000" & sNumber, 3)

If Mid(sNumber, 1, 1) <> "0" Then
Result = GetDigit(Mid(sNumber, 1, 1)) _
& sNWord(28)
If Mid(sNumber, 2, 2) <> "00" Then
Result = Result & sHWord(4)
End If
End If

If Mid(sNumber, 2, 1) <> "0" Then
Result = Result & GetTens(Mid(sNumber, 2), sLang, sCcy)
ElseIf Mid(sNumber, 3, 1) <> "0" Then
Result = Result & GetDigit(Mid(sNumber, 3))
End If

GetHundreds = Result
End Function

Private Function GetTens(TensText As String, _
Optional sLang As String = "English", _
Optional sCcy As String = "USD")
Dim Result As String

Result = ""
If Val(Left(TensText, 1)) = 1 Then   '10-19...
If Val(TensText) > 9 And Val(TensText) < 20 Then
GetTens = sNWord(Val(TensText))
End If
Exit Function
Else                               '20-99...
If Val(Left(TensText, 1)) > 1 And _
Val(Left(TensText, 1)) < 10 Then
Result = sNWord(18 + Val(Left(TensText, 1)))
Else
Result = GetDigit(Right(TensText, 1))
End If
If Right(TensText, 1) <> "0" And Left(TensText, 1) <> "0" Then
Select Case sLang
Case "German"
Result = GetDigit(Right(TensText, 1)) & _
sHWord(4) & Result
Case "English"
Result = Result & GetDigit(Right(TensText, 1))
End Select
End If
End If
GetTens = Result
End Function

Private Function GetDigit(Digit As String) As String
If Val(Digit) < 10 Then
GetDigit = sNWord(Val(Digit))
Else
GetDigit = ""
End If
End Function
``````

Bitte den Haftungsausschluss im Impressum beachten.

sbInWorten.xlsm [29 KB Excel Datei, ohne jegliche Gewährleistung]