winget
Feb 18, 2014, updated at 14:50:10 (UTC)
view4315
view8
0
Goto Top

Zahlen in Buchstaben automatisch umwandeln!

GermansolvedQuestionMicrosoft OfficeMicrosoft
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
comment-contentCommentShareShare
Share on Facebook Share on Twitter Share on Reddit Share on Linkedin

Content-Key: 230263

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

Printed on: April 24, 2024 at 06:04 o'clock

8 Comments
Latest comment
Goto Top
Member: colinardo
Solution colinardo Feb 18, 2014 updated at 14:50:27 (UTC)
Goto Top
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
heart1
Member: winget
winget Feb 18, 2014 updated at 13:13:49 (UTC)
Goto Top
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
Member: colinardo
colinardo Feb 18, 2014 updated at 14:17:12 (UTC)
Goto Top
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
Member: winget
winget Feb 18, 2014 at 13:49:47 (UTC)
Goto Top
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.
Member: colinardo
Solution colinardo Feb 18, 2014 updated at 14:50:10 (UTC)
Goto Top
Ach so, auch kein Thema, schau einfach ins obige Demo-Sheet, hab's da angepasst ...
heart1
Member: winget
winget Feb 18, 2014 updated at 14:49:41 (UTC)
Goto Top
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
Member: colinardo
Solution colinardo Feb 18, 2014 updated at 14:51:47 (UTC)
Goto Top
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
heart1
Member: winget
winget Feb 18, 2014 at 14:51:38 (UTC)
Goto Top
Das stimmt...ich hab's noch geändert..Danke
GermansolvedQuestionMicrosoft OfficeMicrosoft
Hotly discussed
gleixnerdCheck of ZFW Firewallgleixnerd - 5 CommentsjstrickerWireguard VPN on UDM Pro behind Fritzbox - Handshake did not completejstricker - 3 CommentsAlexWishaHow to set up and configure a Linux GRE tunnelAlexWisha - 3 Comments