Zahlen in Buchstaben automatisch umwandeln!

Hallo zusammen,
ich brauche für eine Datei (Zahlungsformular in Excel) in einer Zeile z.B. A1 die Zahlen und in z.B. B1 die Zahlen als Wörter / Buchstaben.

z.B.

A1 = 12345
in B1 soll dann folgendes erscheinen: EINS--ZWEI--DREI--VIER--FÜNF

In der Zeile A1 werden sowieso die Zahlen abgetippt! Damit sollen automatisch in Zeile B1 automatisch die Zahlenwörter automatisch erscheinen.

Ich habe bereits ein Makro, aber die Bedienung ist, dass die Zahl/Zahlen noch mal in der Zelle B1 abgetippt werden und dann das Macro starten und die Zeile (Ziel) im InputBox eingeben.

Anbei der Macro-Code:

Sub umwandeln_Zahlen_in_Wörter()
Dim sZiel As String
 sZiel = InputBox("Geben Sie die Adresse der " & vbCr & _  
         "Zelle mit dem umzuwandelnden " & vbCr & _  
         "Text ein:", "Bitte Zelladresse angeben!")  

For Each zelle In ThisWorkbook.ActiveSheet.Range(sZiel)
   On Error Resume Next
  With zelle
      .Replace What:="1", Replacement:="EINS--"  
      .Replace What:="2", Replacement:="ZWEI--"  
      .Replace What:="3", Replacement:="DREI--"  
      .Replace What:="4", Replacement:="VIER--"  
      .Replace What:="5", Replacement:="FÜNF--"  
      .Replace What:="6", Replacement:="SECHS--"  
      .Replace What:="7", Replacement:="SIEBEN--"  
      .Replace What:="8", Replacement:="ACHT--"  
      .Replace What:="9", Replacement:="NEUN--"  
      .Replace What:="0", Replacement:="NULL--"  
      .Replace What:=".", Replacement:=", "  
  End With
  If Right(zelle, 2) = "--" Then  
    zelle.Value = Application.WorksheetFunction.Replace(zelle, Len(zelle), 1, "")  
    zelle.Value = Application.WorksheetFunction.Replace(zelle, Len(zelle), 1, "")  
  End If
    zelle.Value = Application.WorksheetFunction.Replace(zelle, InStr(2, zelle, ", ") - 2, 2, "")  
 Next zelle
 sZiel = ""  
End Sub

Kann mir jemand helfen, diese Eingabe zu automatisieren?

Vielen Dank im Voraus

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 230263

Url: https://administrator.de/contentid/230263

Ausgedruckt am: 22.11.2024 um 21:11 Uhr

8 Kommentare

Neuester Kommentar

Hallo winget,
füge das mal in den Code des entsprechenden Sheets ein:
Im Beispiel wird bei jeder Änderung der Zellen "A1:A10" der entsprechende Wert automatisch in die Zelle daneben geschrieben, sobald man die Bearbeitung der Zelle abschließt.

Private Sub Worksheet_Change(ByVal Target As Range)
     On Error Resume Next
    'Range bei dem eine Änderung etwas bewirken soll  
    Set changeRange = Range("A1:A10")  
    If Not Application.Intersect(changeRange, Target) Is Nothing Then
        If Target.Value <> "" Then  
            Set rngTarget = Target.Offset(0, 1)
            strText = Replace(Target.Value, "1", "EINS--", 1, -1, vbTextCompare)  
            strText = Replace(strText, "2", "ZWEI--", 1, -1, vbTextCompare)  
            strText = Replace(strText, "3", "DREI--", 1, -1, vbTextCompare)  
            strText = Replace(strText, "4", "VIER--", 1, -1, vbTextCompare)  
            strText = Replace(strText, "5", "FÜNF--", 1, -1, vbTextCompare)  
            strText = Replace(strText, "6", "SECHS--", 1, -1, vbTextCompare)  
            strText = Replace(strText, "7", "SIEBEN--", 1, -1, vbTextCompare)  
            strText = Replace(strText, "8", "ACHT--", 1, -1, vbTextCompare)  
            strText = Replace(strText, "9", "NEUN--", 1, -1, vbTextCompare)  
            strText = Replace(strText, "0", "NULL--", 1, -1, vbTextCompare)  
            strText = Replace(strText, ".", ", ", 1, -1, vbTextCompare)  
            If Right(strText, 2) = "--" Then  
                strText = Left(strText, Len(strText) - 2)
            End If
            strText = Replace(strText, "--,", ",", 1, -1, vbTextCompare)  
            rngTarget.Value = strText
        End If
    End If
End Sub

Siehe auch das Demo-Sheet

Grüße Uwe

Hi colinardo,
das funktioniert schon mal super, auch mit meinem Sheet (ich habe für mich entsprechend angepasst).

Ich habe leider von Anfang an nicht gesagt, dass ich noch ein Blatt habe, wo die Einzelbeträge eintrage.

z.B.

Sheet1 > A1:A10 werden z.B. Beträge abgetippt. In A11 wird die Summe erzeugt
Sheet2 > wie gehabt. In A1 wird der Betrag aus Sheet1_A11 übertragen. In B1 soll wie oben entsprechend funktionieren. Es funktioniert nur, wenn ich noch mal in die Zelle Sheet2_A1 rein gehe und Enter drucke.

Danke schon mal für die erste Lösung!

Gruß
Paul

Das ist auch kein Problem,
dazu machst du aus der Prozedur eine Public Function und fügst sie in ein Modul ein:

Public Function zahlToText(zahl)
    strText = Replace(zahl, "1", "EINS--", 1, -1, vbTextCompare)  
    strText = Replace(strText, "2", "ZWEI--", 1, -1, vbTextCompare)  
    strText = Replace(strText, "3", "DREI--", 1, -1, vbTextCompare)  
    strText = Replace(strText, "4", "VIER--", 1, -1, vbTextCompare)  
    strText = Replace(strText, "5", "FÜNF--", 1, -1, vbTextCompare)  
    strText = Replace(strText, "6", "SECHS--", 1, -1, vbTextCompare)  
    strText = Replace(strText, "7", "SIEBEN--", 1, -1, vbTextCompare)  
    strText = Replace(strText, "8", "ACHT--", 1, -1, vbTextCompare)  
    strText = Replace(strText, "9", "NEUN--", 1, -1, vbTextCompare)  
    strText = Replace(strText, "0", "NULL--", 1, -1, vbTextCompare)  
    strText = Replace(strText, ".", ", ", 1, -1, vbTextCompare)  
    If Right(strText, 2) = "--" Then  
        strText = Left(strText, Len(strText) - 2)
    End If
    strText = Replace(strText, "--,", ",", 1, -1, vbTextCompare)  
    zahlToText = strText
End Function

dann fügst du folgenden Code in jedes Sheet ein welches diese Funktion haben soll:

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Set changeRange = Range("A1:A10")  
    If Not Application.Intersect(changeRange, Target) Is Nothing Then
            If Target.Value <> "" Then  
                Target.Offset(0, 1).Value = zahlToText(Target.Value)
            Else
                Target.Offset(0, 1).Value = ""  
            End If
    End If
End Sub

Demo Sheet von oben ist darauf hin aktualisiert, falls das nicht klar war.

Grüße Uwe

Ich verstehe, was du meinst, aber das ist nicht das Problem.
Ich wollte dir meine Beispiel Datei hier hoch laden, aber ich habe leider nicht gefunden, wie es geht!

Ich versuche noch mal zu Erklären.

Tabelle1 und Tabelle2 (keine weiter Tabellen)

In Tabelle1 (A1:A10) sind die Zahlen, die abgetippt werden! In A11 ist die Summe
In Tabelle2 A1 ist die Summe aus Tablle1_A11 und die B1 die Buchstabenumwandlung die Umwandlung von Zahlen in Wörter.

Ändert sich eine Zahl in Tabelle1 in Zellen A1:A10, ändert sich natürlich auch die Summe in A11 (Tabelle1) aber auch der Betrag in Tabelle2_A1. Aber die Umwandlung in B1 funktioniert nicht automatisch > nur wenn man z.B. in die Zelle Tabelle2_A1 rein geht und Enter druckt.

Ich hoffe, dass das jetzt einigermaßen verständlich ist.

Ach so, auch kein Thema, schau einfach ins obige Demo-Sheet, hab's da angepasst ...

Super geholfen!
Ich habe der Code ein bisschen angepasst. In der Tabelle1 sollen keine Umwandlung stattfinden.
Siehe unten die Endlösung, was ich eigentlich suchte. Auch für andere Forumsuser, die sowas brauchen.
Vielen vielen Dank

Publich function wie gehabt (z.B. Modul1)

Public Function zahlToText(zahl)
    strText = Replace(zahl, "1", "EINS--", 1, -1, vbTextCompare)  
    strText = Replace(strText, "2", "ZWEI--", 1, -1, vbTextCompare)  
    strText = Replace(strText, "3", "DREI--", 1, -1, vbTextCompare)  
    strText = Replace(strText, "4", "VIER--", 1, -1, vbTextCompare)  
    strText = Replace(strText, "5", "FÜNF--", 1, -1, vbTextCompare)  
    strText = Replace(strText, "6", "SECHS--", 1, -1, vbTextCompare)  
    strText = Replace(strText, "7", "SIEBEN--", 1, -1, vbTextCompare)  
    strText = Replace(strText, "8", "ACHT--", 1, -1, vbTextCompare)  
    strText = Replace(strText, "9", "NEUN--", 1, -1, vbTextCompare)  
    strText = Replace(strText, "0", "NULL--", 1, -1, vbTextCompare)  
    strText = Replace(strText, ".", ", ", 1, -1, vbTextCompare)  
    If Right(strText, 2) = "--" Then  
        strText = Left(strText, Len(strText) - 2)
    End If
    strText = Replace(strText, "--,", ",", 1, -1, vbTextCompare)  
    zahlToText = strText
End Function

und Sheet (Blatt) Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Set changeRange = Range("A1:A10")  
    If Not Application.Intersect(changeRange, Target) Is Nothing Then
        Worksheets(2).Range("B1").Value = zahlToText(Worksheets(2).Range("A1").Value)  
    End If
End Sub

alles klar,
Zeile 3 in der Function ist noch doppelt, die kannst du noch löschen.

Wenns das dann war, den Beitrag bitte noch auf gelöst setzen, und die Lösungskommentare markieren. Merci.

Grüße Uwe