Impressum und Haftungsaus-
schluss lesen

InWorten

Eine kleine Excel©-Anwendung für den Buchhaltungsbereich, wenn man Beträge widerspruchsfrei in Worten als Betrag in Euro und Cent auf den Cent gerundet wiederholen möchte (Die vorgestellten Programmbeispiele sind als Anregung und Lehrbeispiele zu verstehen. Für ordnungsgemäße Funktion, Fehler- oder Virenfreiheit wird keine Garantie übernommen. Siehe auch Haftungsausschluss):

Option Explicit

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

Function InWorten(ByVal sNumber As String) As String
   InWorten = SpellNumber(sNumber, "German", "EUR")
End Function

Function SpellNumber(ByVal sNumber As String, _
           Optional sLang As String = "English", _
           Optional sCcy As String = "USD") As String
'Template was Microsoft's limited version:
'
http://support.microsoft.com/kb/213360
'This version informs the user about its limits.
'Reverse("moc.liborplus.www") PB 02-Mar-2018 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
   SpellNumber = 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
   
SpellNumber = 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

[Home] [Über uns] [Unser Angebot] [Infopool] [Kontakt] [Impressum] [AGB]