Thema: Anzeige, wenn Listenwerte gefunden werden

ClassModule: Tabelle1

Private Sub cmdDialogAufruf_Click()
   frmZahlwort.Show
End Sub

ClassModule: frmZahlwort

Private Sub cmdWeiter_Click()
   Unload Me
End Sub

Private Sub txtNumber_Change()
   txtWord.Text = ZahlWort(CDbl(txtNumber.Text))
End Sub

StandardModule: basMain

Sub CallForm()
   frmZahlwort.Show
End Sub

Function ZahlWort(dblZahl As Double, Optional bolArt As Variant)
   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
         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

Beiträge aus dem Excel-Forum zu den Themen Funktion und WENN