AW: benutzerdefinierte Funktion für mehrere Sprach
03.02.2008 14:11:00
Nepumuk
Hallo Max,
hier mal eine Funktion dazu. Allerdings nur in deutsch. Aber mit "VBA gut" solltest du dir das schon hinbiegen können.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Public Function ZahlWort(dblZahl As Double, Optional bolArt As Variant) As String
Dim arrArt As Variant
Dim intCounter As Integer, intCts As Integer
Dim strWert As String, strTmp As String, strSuffix As String
On Error Resume Next
If bolArt = 1 Then
If Err = 0 Then
intCts = (dblZahl - Fix(dblZahl)) * 100
If intCts <> 0 Then strSuffix = " " & Format(CStr(intCts), "00") & "/100"
Else
bolArt = 0
End If
End If
On Error GoTo 0
dblZahl = Fix(dblZahl)
strTmp = Right$(CStr(dblZahl), 3)
strWert = Part(strTmp)
For intCounter = 1 To 4
strTmp = CStr(dblZahl)
Select Case Len(strTmp)
Case Is < 1 + 3 * intCounter
ZahlWort = strWert & strSuffix
Exit Function
Case Is < 4 + 3 * intCounter
strTmp = Left$(strTmp, Len(strTmp) - intCounter * 3)
Case Else
strTmp = Left$(Right$(strTmp, 3 + intCounter * 3), 3)
End Select
Select Case intCounter
Case 1: arrArt = Array("tausend", "eintausend")
Case 2: arrArt = Array("millionen", "einemillion")
Case 3: arrArt = Array("milliarden", "einemillarde")
Case 4: arrArt = Array("billionen", "einebillion")
End Select
If Right$(CStr(dblZahl), 3) = "000" Then
strWert = Part(strTmp) & arrArt(0)
ElseIf Cint(strTmp) = 1 Then
strWert = arrArt(1) & strWert
Else
strWert = Part(strTmp) & arrArt(0) & strWert
End If
Next intCounter
ZahlWort = strWert & strSuffix
End Function
Private Function Part(strPart As String) As String
Dim arrA As Variant, arrB As Variant, arrC As Variant
Dim strTmp As String
arrA = Array("null", "eins", "zwei", "drei", "vier", "fünf", "sechs", "sieben", "acht", "neun")
arrB = Array("elf", "zwölf", "dreizehn", "vierzehn", "fünfzehn", "sechzehn", "siebzehn", "achtzehn", "neunzehn")
arrC = Array("zehn", "zwanzig", "dreißig", "vierzig", "fünfzig", "sechzig", "siebzig", "achtzig", "neunzig")
If Len(strPart) = 1 Then
strTmp = arrA(Cint(Right$(strPart, 1)))
ElseIf Right$(strPart, 2) = "00" Then
If Left$(strPart, 1) = "1" Then
Part = "einhundert"
Else
Part = arrA(Cint(Left$(strPart, 1))) & "hundert"
End If
Exit Function
ElseIf Mid$(strPart, Len(strPart) - 1, 1) = "0" Then
strTmp = arrA(Cint(Right$(strPart, 1)))
ElseIf Mid$(strPart, Len(strPart) - 1, 1) = "1" Then
If Cint(Right$(strPart, 1)) <> 0 Then
strTmp = arrB(Cint(Right$(strPart, 2)) - 11)
Else
strTmp = arrC(Cint(Mid$(strPart, Len(strPart) - 1, 1)) - 1)
End If
ElseIf Cint(Mid$(strPart, Len(strPart) - 1, 1)) > 1 Then
Select Case Right$(strPart, 1)
Case "0"
strTmp = arrC(Cint(Mid$(strPart, Len(strPart) - 1, 1)) - 1)
Case "1"
strTmp = "einund" & _
arrC(Cint(Mid$(strPart, Len(strPart) - 1, 1)) - 1)
Case Else
strTmp = arrA(Cint(Right$(strPart, 1))) & "und" & _
arrC(Cint(Mid$(strPart, Len(strPart) - 1, 1)) - 1)
End Select
End If
If Len(strPart) = 3 Then
Select Case Left$(strPart, 1)
Case "0"
Case "1"
strTmp = "einhundert" & strTmp
Case Else
strTmp = arrA(Cint(Left$(strPart, 1))) & "hundert" & strTmp
End Select
End If
Part = strTmp
End Function
In der Tabelle dann so:
| | A | B |
| 1 | 2.277,34 | zweitausendzweihundertsiebenundsiebzig 34/100 |
| 2 | 22,00 | zweiundzwanzig |
| 3 | 33,70 | dreiunddreißig 70/100 |
| 4 | - | null |
| 5 | 1.111,00 | eintausendeinhundertelf |
| 6 | 1.984,00 | eintausendneunhundertvierundachtzig |
| 7 | 2.003,00 | zweitausenddrei |
| Formeln der Tabelle |
| Zelle | Formel | | B1 | =WENN(ISTZAHL(A1); zahlwort(A1;1); "") | | B2 | =WENN(ISTZAHL(A2); zahlwort(A2;1); "") | | B3 | =WENN(ISTZAHL(A3); zahlwort(A3;1); "") | | B4 | =WENN(ISTZAHL(A4); zahlwort(A4;1); "") | | B5 | =WENN(ISTZAHL(A5); zahlwort(A5;1); "") | | B6 | =WENN(ISTZAHL(A6); zahlwort(A6;1); "") | | B7 | =WENN(ISTZAHL(A7); zahlwort(A7;1); "") |
|
Gruß
Nepumuk
