Attribute VB_Name = "Modul2"
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