Zahlen als Text ausschreiben

[Royalty]

Ich möchte Zahlen als Text ausgeben und habe hierzu einen VBA-Code. Dieses funktioniert auch im Zahlenbereich bis tausend.... allerdings hat der Code ein Problem, mit den folgenden Zahlen... 1000., 2000, 3000 usw.

Hier wirft mir der Code immer einundtausend, zweiundtausend, dreiundtausen usw. aus, wobei 1001 wieder richtig mit eintausendeins ausgegeben wird.

Hier mal der VBA-Code:

Function inWorten(var As Variant) As String
   Dim j As Byte
   Dim strZahl As String
   Dim sX1   As String     '1 Zeichen
   Dim sX3   As String     '3 Zeichen
   Dim sVal  As String     'millionen,tausend,hundert
   If Val(var) > 999999999 Then inWorten = "": Exit Function
   var = Int(CDbl(var) / 1)
   strZahl = String(9 - Len(CStr(var)), "0") & CStr(var)
   For j = 0 To 2
     sX3 = Mid(strZahl, j * 3 + 1, 3)
     Select Case j
     Case 0
       sVal = "million"
       If Val(Right(sX3, 1)) > 1 Then sVal = "millionen"
     Case 1
       sVal = "tausend"
     Case 2
       sVal = ""
     Case 3
       sVal = ""
     End Select
     If Val(sX3) > 0 Then
       inWorten = inWorten & Z2W(Left(sX3, 1), "hundert")
       inWorten = inWorten & Z2W(Right(sX3, 1), "und") 'und gelöscht
       inWorten = inWorten & Z2W0(Mid(sX3, 2, 1))
       If inWorten Like "*undzehn" Then
         inWorten = WorksheetFunction.Substitute(inWorten, "einundzehn", "elf")
         inWorten = WorksheetFunction.Substitute(inWorten, "zweiundzehn", "zwölf")
         inWorten = WorksheetFunction.Substitute(inWorten, "undzehn", "zehn")
         inWorten = WorksheetFunction.Substitute(inWorten, "szehn", "zehn")
         inWorten = WorksheetFunction.Substitute(inWorten, "enzehn", "zehn")
       End If
   
      If inWorten Like "*undtausend*" Then
         inWorten = WorksheetFunction.Substitute(inWorten, "undtausend", "tausend")
      End If
                       
       If inWorten Like "*undmillion*" Then
         inWorten = WorksheetFunction.Substitute(inWorten, "einundmillion", "einemillion")
         inWorten = WorksheetFunction.Substitute(inWorten, "undmillion", "million")
       End If
       inWorten = WorksheetFunction.Substitute(inWorten, "undnull", "")
       inWorten = inWorten & sVal
     End If
   Next
   If Right(inWorten, 3) = "und" Then inWorten = Left(inWorten, Len(inWorten) - 3)
   If Right(inWorten, 3) = "ein" Then inWorten = inWorten & "s"
End Function

 
 
Function Z2W(ziffer As Byte, Optional sOpt As String) As String
   Select Case ziffer
   Case 0: Z2W = ""
   Case 1: Z2W = "ein"
   Case 2: Z2W = "zwei"
   Case 3: Z2W = "drei"
   Case 4: Z2W = "vier"
   Case 5: Z2W = "fünf"
   Case 6: Z2W = "sechs"
   Case 7: Z2W = "sieben"
   Case 8: Z2W = "acht"
   Case 9: Z2W = "neun"
   End Select
   If sOpt <> "" And Z2W <> "" Then Z2W = Z2W & sOpt
End Function

 
 
Function Z2W0(ziffer As Byte) As String
   Select Case ziffer
   Case 0: Z2W0 = ""
   Case 1: Z2W0 = "zehn"
   Case 2: Z2W0 = "zwanzig"
   Case 3: Z2W0 = "dreissig"
   Case 4: Z2W0 = "vierzig"
   Case 5: Z2W0 = "fünfzig"
   Case 6: Z2W0 = "sechzig"
   Case 7: Z2W0 = "siebzig"
   Case 8: Z2W0 = "achtzig"
   Case 9: Z2W0 = "neunzig"
   End Select
End Function

Hat jemand eine Idee, was ich noch probieren könnte? Eine Testdatei habe ich mal angefügt, wo in Zelle A1 der Betrag als Zahl eingegeben wird und dann als Text in A2 ausgegeben wird.

Gruß
Roy

P.S. Auch ab 1.000.000 besteht ein Problem, auch wieder mit dem "und".

[Case]

Hallo,

du musst die Prüfung außerhalb von "If Val(sX3) > 0 Then" machen:

  Test.xlsm (Größe: 17,94 KB / Downloads: 2)

[Royalty]

Jupp, danke

[snb]

Vielleicht reicht die angehängte Datei.

[Case]

Hallo,

habe noch etwas gestöbert und verschiedenes gefunden. Per Formel, VBA oder sogar mit Power Query:

Zahl in Worten...

Zahl in Worten...

Zahl in Worten...

Zahl in Worten...

Zahl in Worten...

Zahl in Worten...

Zahl in Worten...

Einige mit Download. Manche müssen noch eingedeutscht werden.