#1
|
|||
|
|||
Zahlen ausgeschrieben darstellen
Guten Tag ich möchte das Zahlen in Word ausgeschrieben dargestellt werden.
Also das 123 per Tasteklick Einhundertdreiundzwanzig wird. Das habe ich mit Folgendem Befehl auch schon ganz gut hinbekommen: Sub Makro1() ' ' Makro1 Makro ' ' Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _ PreserveFormatting:=False Selection.TypeText Text:="=" Selection.MoveRight Unit:=wdCharacter, Count:=4 Selection.MoveLeft Unit:=wdCharacter, Count:=1 Selection.TypeText Text:="\*CARDTEXT" Selection.Fields.Update End Sub Das Problem ist nun das wenn ich z.B 1 oder 1234567 eigebe das nicht funktioniert. Wenn ich den .MoveRight Count auf 3 stelle funktioniern 1 & 2stellige Zahlen wenn ich ihn auf 5 stelle 3&4stellige. Ich möchte aber das alle erkannt werden.. :-/ Das Problem ist (soweit ich das verstanden habe) das der \*CARDTEXT Befehl auserhalb de Klammer eingefügt wird wenn die Zahl zu groß wird. Was ich nicht verstehe ist wenn ich den Counter auf 5 stelle warum er dann nur 3&4stellige Zahlen erkennt... Kann mir jemand erklären wie das funktioniert bzw. das Script einfügen? :-) Danke! |
#2
|
|||
|
|||
Use the following:
Code:
Dim rng As Range Dim str As String Dim fld As Field With Selection str = .Text Set fld = ActiveDocument.Fields.Add(.Range, wdFieldEmpty, True) Set rng = fld.Code rng.Text = "= " & str & "\* CARDTEXT" fld.Update End With If you want to convert larger numbers (up to 12 digits), you could use: Code:
' a Macro to insert cardtext for numbers up to 999,999,999,999 ' Macro created 29/09/99 by Doug Robbins With Selection.Find .Text = "," .Replacement.Text = "" .Forward = True .Wrap = wdFindStop End With Selection.Find.Execute Replace:=wdReplaceAll numtext$ = Int(Val(Selection.Text)) If Val(numtext$) < 1000000 Then Selection.Delete Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _ PreserveFormatting:=False Selection.TypeText Text:="=" & Val(numtext$) & " \* CardText" ActiveWindow.View.ShowFieldCodes = Not ActiveWindow.View.ShowFieldCodes ActiveWindow.View.ShowFieldCodes = Not ActiveWindow.View.ShowFieldCodes Selection.Fields.Update ElseIf Len(numtext$) < 10 Then millions = Val(Left(numtext$, Len(numtext$) - 6)) Balance = Val(Right(numtext$, Len(numtext$) - Len(millions))) Selection.Delete Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _ PreserveFormatting:=False Selection.TypeText Text:="=" & millions & " \* CardText" Selection.MoveRight Unit:=wdCharacter, Count:=2 Selection.TypeText Text:=" million " Selection.Collapse Direction:=wdCollapseEnd If Balance <> 0 Then Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _ PreserveFormatting:=False Selection.TypeText Text:="=" & Balance & " \* CardText" End If ActiveWindow.View.ShowFieldCodes = Not ActiveWindow.View.ShowFieldCodes ActiveWindow.View.ShowFieldCodes = Not ActiveWindow.View.ShowFieldCodes ActiveDocument.Fields.Update ElseIf Len(numtext$) < 14 Then billions = Val(Left(numtext$, Len(numtext$) - 9)) millions = Val(Mid(numtext$, Len(billions) + 1, 3)) Balance = Val(Right(numtext$, Len(numtext$) - Len(millions) - Len(billions))) Selection.Delete Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _ PreserveFormatting:=False Selection.TypeText Text:="=" & billions & " \* CardText" Selection.MoveRight Unit:=wdCharacter, Count:=2 Selection.TypeText Text:=" billion " Selection.Collapse Direction:=wdCollapseEnd If millions <> 0 Then Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _ PreserveFormatting:=False Selection.TypeText Text:="=" & millions & " \* CardText" Selection.MoveRight Unit:=wdCharacter, Count:=2 Selection.TypeText Text:=" million " Selection.Collapse Direction:=wdCollapseEnd End If If Balance <> 0 Then Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _ PreserveFormatting:=False Selection.TypeText Text:="=" & Balance & " \* CardText" End If ActiveWindow.View.ShowFieldCodes = Not ActiveWindow.View.ShowFieldCodes ActiveWindow.View.ShowFieldCodes = Not ActiveWindow.View.ShowFieldCodes ActiveDocument.Fields.Update End If You may need to change the grouping symbol for your region. |
#3
|
|||
|
|||
Works well, Thank you very much! :-)
How can i change to German - I have millions & billions i need that in German, than it's perfect and i don't find the grouping symbol.. How can i set it? Thank you! |
#4
|
|||
|
|||
The Grouping Symbol can be set under the Windows Control Panel>Clock Language and Region.
For German, try Code:
Function ConvertCurrencyToGerman(ByVal MyNumber) Dim Temp Dim Dollars, Cents Dim DecimalPlace, Count ReDim Place(9) As String Place(2) = " Tausend " Place(3) = " Million " Place(4) = " Billion " Place(5) = " Trillion " MyNumber = Trim(str(MyNumber)) DecimalPlace = InStr(MyNumber, ".") If DecimalPlace > 0 Then Temp = Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2) Cents = ConvertTens(Temp) MyNumber = Trim(Left(MyNumber, DecimalPlace - 1)) End If Count = 1 Do While MyNumber <> "" 'convert last 3 digits to German Dollars Temp = ConvertHunderts(Right(MyNumber, 3)) If Temp <> "" Then Dollars = Temp & Place(Count) & Dollars If Len(MyNumber) > 3 Then 'remove last 3 comverted digits MyNumber = Left(MyNumber, Len(MyNumber) - 3) Else MyNumber = "" End If Count = Count + 1 Loop 'clean up dollars Select Case Dollars Case "" Dollars = "NoDollars" Case "One" Dollars = "One Dollar" Case Else Dollars = Dollars & " Dollars" End Select 'clean up cents Select Case Cents Case "" Cents = " And No Cents" Case "One" Cents = " And One Cent" Case Else Cents = " And " & Cents & " Cents" End Select ConvertCurrencyToGerman = Dollars & Cents End Function Private Function ConvertHunderts(ByVal MyNumber) Dim Result As String If Val(MyNumber) = 0 Then Exit Function 'append leading zeros to number MyNumber = Right("000" & MyNumber, 3) 'do we have Hunderts place digit to convert? If Left(MyNumber, 1) <> "0" Then Result = ConvertDigit(Left(MyNumber, 1)) & " Hundert " End If 'do we have tens place digit to convert? If Mid(MyNumber, 2, 1) <> "0" Then Result = Result & ConvertTens(Mid(MyNumber, 2)) Else 'if not, then convert the ones place digit Result = Result & ConvertDigit(Mid(MyNumber, 3)) End If ConvertHunderts = Trim(Result) End Function Private Function ConvertTens(ByVal MyTens) Dim Result As String 'is value between 10 and 19? If Val(Left(MyTens, 1)) = 1 Then Select Case Val(MyTens) Case 10: Result = "Zehn" Case 11: Result = "Elf" Case 12: Result = "Zwölf" Case 13: Result = "Dreizehn" Case 14: Result = "Vierzehn" Case 15: Result = "Fünfzehn" Case 16: Result = "Sechszehn" Case 17: Result = "Siebzehn" Case 18: Result = "Achtzehn" Case 19: Result = "Neunzehn" Case Else End Select Else Select Case Val(Left(MyTens, 1)) Case 2: Result = "Zwanzig " Case 3: Result = "Dreißig " Case 4: Result = "Vierzig " Case 5: Result = "Fünfzig " Case 6: Result = "Sechzig " Case 7: Result = "Siebzig " Case 8: Result = "Achtzig " Case 9: Result = "Neunzig " Case Else End Select 'convert ones place digit Result = Result & ConvertDigit(Right(MyTens, 1)) End If ConvertTens = Result End Function Private Function ConvertDigit(ByVal MyDigit) Select Case Val(MyDigit) Case 1: ConvertDigit = "Eins" Case 2: ConvertDigit = "Zwei" Case 3: ConvertDigit = "Drei" Case 4: ConvertDigit = "Vier" Case 5: ConvertDigit = "Fünf " Case 6: ConvertDigit = "Sechs" Case 7: ConvertDigit = "Sieben" Case 8: ConvertDigit = "Acht" Case 9: ConvertDigit = "Neun" Case Else: ConvertDigit = "" End Select End Function Sub TestAboveFunction() Dim MyNumber MyNumber = 551521896.32 MsgBox ConvertCurrencyToGerman(ByVal MyNumber) End Sub |
#5
|
|||
|
|||
So hi again. No unfortunaly it don't work. I get this reponse when i try it with any number. The first script works well only in English. That's the only Problem.. Thanks very very much for your Help again.
Pop-up Word when i try to start the Makro with any number: Microsoft Word: "Fünf Hundert Fünfzig Eins Milion Fünf Hundert Zwanzig Eins Tausend Acht Hundert Neunzig Sechs Dollars And Dreißig Zwei Cents" Thank you!! |
#6
|
|||
|
|||
When you have the number selected, run a macro such as:
Code:
Sub ConvertSelectiontoGerman() Dim MyNumber MyNumber = Selection.Text Selection.Text = ConvertCurrencyToGerman(ByVal MyNumber) End Sub |
Tags |
count logic, german, problem |
|