Sulprobil
Search…
sbSpellNumber
Sometimes you need to spell numbers in English words with Dollars/Cents or british Pound Sterling/Pence or European Euros/Cents. 12.31 would result in Twelve Dollars and Thirtyone Cents, for example.
Other examples:
Please read my Disclaimer.
1
Private sNWord(0 To 28) As String
2
Private sHWord(1 To 4) As String
3
4
Function sbInWorten(ByVal sNumber As String) As String
5
sbInWorten = sbSpellNumber(sNumber, "German", "EUR")
6
End Function
7
8
Function sbSpellNumber(ByVal sNumber As String, _
9
Optional sLang As String = "English", _
10
Optional sCcy As String = "USD") As String
11
'Template was Microsoft's limited version:
12
'https://support.microsoft.com/de-de/help/213360/
13
'how-to-convert-a-numeric-value-into-english-words-in-excel
14
'This version informs the user about its limits.
15
'Reverse("moc.liborplus.www") PB 02-Mar-2018 V1.0
16
17
Dim Euros As String, cents As String
18
Dim Result As String, Temp As String
19
Dim DecimalPlace As Integer, Count As Integer
20
Dim Place(1 To 6) As String
21
Dim dNumber As Double
22
Dim prefix As String, suffix As String
23
24
Select Case sLang
25
Case "English"
26
Place(1) = ""
27
Place(2) = " Thousand "
28
Place(3) = " Million "
29
Place(4) = " Billion "
30
Place(5) = " Trillion "
31
Place(6) = " Mantissa not wide enough for this number "
32
sHWord(1) = ">>>>> Error (Absolute amount > 999999999999999)! <<<<<"
33
sHWord(2) = " (rounded)"
34
sHWord(3) = "Minus "
35
sHWord(4) = "and"
36
sNWord(0) = "zero"
37
sNWord(1) = "one"
38
sNWord(2) = "two"
39
sNWord(3) = "three"
40
sNWord(4) = "four"
41
sNWord(5) = "five"
42
sNWord(6) = "six"
43
sNWord(7) = "seven"
44
sNWord(8) = "eight"
45
sNWord(9) = "nine"
46
sNWord(10) = "ten"
47
sNWord(11) = "eleven"
48
sNWord(12) = "twelve"
49
sNWord(13) = "thirteen"
50
sNWord(14) = "fourteen"
51
sNWord(15) = "fifteen"
52
sNWord(16) = "sixteen"
53
sNWord(17) = "seventeen"
54
sNWord(18) = "eighteen"
55
sNWord(19) = "nineteen"
56
sNWord(20) = "twenty"
57
sNWord(21) = "thirty"
58
sNWord(22) = "fourty"
59
sNWord(23) = "fifty"
60
sNWord(24) = "sixty"
61
sNWord(25) = "seventy"
62
sNWord(26) = "eighty"
63
sNWord(27) = "ninety"
64
sNWord(28) = "hundred"
65
Case "German"
66
Place(1) = ""
67
Place(2) = " Tausend "
68
Place(3) = " Millionen "
69
Place(4) = " Milliarden "
70
Place(5) = " Billionen "
71
Place(6) = " Die Mantisse ist nicht groß genug für diese Zahl "
72
sHWord(1) = ">>>>> Fehler (Absolutbetrag > 999999999999999)! <<<<<"
73
sHWord(2) = " (gerundet)"
74
sHWord(3) = "Minus "
75
sHWord(4) = "und"
76
sNWord(0) = "null"
77
sNWord(1) = "ein"
78
sNWord(2) = "zwei"
79
sNWord(3) = "drei"
80
sNWord(4) = "vier"
81
sNWord(5) = "fünf"
82
sNWord(6) = "sechs"
83
sNWord(7) = "sieben"
84
sNWord(8) = "acht"
85
sNWord(9) = "neun"
86
sNWord(10) = "zehn"
87
sNWord(11) = "elf"
88
sNWord(12) = "zwölf"
89
sNWord(13) = "dreizehn"
90
sNWord(14) = "vierzehn"
91
sNWord(15) = "fünfzehn"
92
sNWord(16) = "sechzehn"
93
sNWord(17) = "siebzehn"
94
sNWord(18) = "achtzehn"
95
sNWord(19) = "neunzehn"
96
sNWord(20) = "zwanzig"
97
sNWord(21) = "dreißig"
98
sNWord(22) = "vierzig"
99
sNWord(23) = "fünfzig"
100
sNWord(24) = "sechzig"
101
sNWord(25) = "siebzig"
102
sNWord(26) = "achtzig"
103
sNWord(27) = "neunzig"
104
sNWord(28) = "hundert"
105
End Select
106
107
'Empty string = 0
108
If "" = sNumber Then
109
sNumber = "0"
110
End If
111
112
dNumber = sNumber + 0#
113
114
'If we cannot cope with it, tell the user!
115
If Abs(dNumber) > 999999999999999# Then
116
sbSpellNumber = sHWord(1)
117
Exit Function
118
End If
119
120
'If we have to round we present a suffix "(rounded)"
121
If Abs(dNumber - Round(dNumber, 2)) > 1E-16 Then
122
dNumber = Round(dNumber, 2)
123
suffix = sHWord(2)
124
End If
125
126
'Negative numbers get a prefix "Minus"
127
If dNumber < 0# Then
128
prefix = sHWord(3)
129
dNumber = -dNumber
130
sNumber = Right(sNumber, Len(sNumber) - 1)
131
End If
132
133
sNumber = Trim(Str(sNumber))
134
If Left(sNumber, 1) = "." Then
135
sNumber = "0" & sNumber
136
End If
137
138
DecimalPlace = InStr(sNumber, ".")
139
140
If DecimalPlace > 0 Then
141
cents = GetTens(Left(Mid(sNumber, DecimalPlace + 1) & "00", 2), _
142
sLang, sCcy)
143
sNumber = Trim(Left(sNumber, DecimalPlace - 1))
144
End If
145
146
Count = 1
147
Do While sNumber <> ""
148
Temp = GetHundreds(Right(sNumber, 3), sLang, sCcy)
149
If Temp <> "" Then
150
If Euros <> "" And sLang = "German" Then
151
Euros = Temp & Place(Count) & " " & _
152
sHWord(4) & " " & Euros
153
Else
154
Euros = Temp & Place(Count) & Euros
155
End If
156
End If
157
If Len(sNumber) > 3 Then
158
sNumber = Left(sNumber, Len(sNumber) - 3)
159
Else
160
sNumber = ""
161
End If
162
Count = Count + 1
163
Loop
164
165
Select Case sCcy
166
Case "EUR"
167
Select Case Euros
168
Case ""
169
Euros = sNWord(0) & " Euros"
170
Case sNWord(1)
171
Euros = sNWord(1) & " Euro"
172
Case Else
173
Euros = Euros & " Euros"
174
End Select
175
176
Select Case cents
177
Case ""
178
cents = " " & sHWord(4) & " " & sNWord(0) & " Cents"
179
Case sNWord(1)
180
cents = " " & sHWord(4) & " " & sNWord(1) & " Cent"
181
Case Else
182
cents = " " & sHWord(4) & " " & cents & " Cents"
183
End Select
184
Case "GBP"
185
Select Case Euros
186
Case ""
187
Euros = sNWord(0) & " Pounds"
188
Case sNWord(1)
189
Euros = sNWord(1) & " Pound"
190
Case Else
191
Euros = Euros & " Pounds"
192
End Select
193
194
Select Case cents
195
Case ""
196
cents = " " & sHWord(4) & " " & sNWord(0) & " Pence"
197
Case sNWord(1)
198
cents = " " & sHWord(4) & " " & sNWord(1) & " Penny"
199
Case Else
200
cents = " " & sHWord(4) & " " & cents & " Pence"
201
End Select
202
Case "USD"
203
Select Case Euros
204
Case ""
205
Euros = sNWord(0) & " Dollars"
206
Case sNWord(1)
207
Euros = sNWord(1) & " Dollar"
208
Case Else
209
Euros = Euros & " Dollars"
210
End Select
211
212
Select Case cents
213
Case ""
214
cents = " " & sHWord(4) & " " & sNWord(0) & " Cents"
215
Case sNWord(1)
216
cents = " " & sHWord(4) & " " & sNWord(1) & " Cent"
217
Case Else
218
cents = " " & sHWord(4) & " " & cents & " Cents"
219
End Select
220
End Select
221
222
Temp = UCase(Replace(Euros & cents, " ", " "))
223
Select Case sLang
224
Case "English"
225
Temp = Application.WorksheetFunction.Proper(Temp)
226
Temp = Replace(Temp, " And ", " and ")
227
Case "German"
228
Temp = Application.WorksheetFunction.Proper(Temp)
229
Temp = Replace(Temp, "Ein Millionen", "Eine Million")
230
Temp = Replace(Temp, "Ein Milliarden", "Eine Milliarde")
231
Temp = Replace(Temp, "Ein Billionen", "Eine Billion")
232
Temp = Replace(Temp, "Dollars", "Dollar")
233
Temp = Replace(Temp, "Cents", "Cent")
234
Temp = Replace(Temp, "Pounds", "Pfund")
235
Temp = Replace(Temp, "Pound", "Pfund")
236
Temp = Replace(Temp, "Euros", "Euro")
237
Temp = Replace(Temp, "Pence", "Pennies")
238
Temp = Replace(Temp, " Und ", " und ")
239
End Select
240
241
sbSpellNumber = prefix & Temp & suffix
242
243
End Function
244
245
Private Function GetHundreds(ByVal sNumber, _
246
Optional sLang As String = "English", _
247
Optional sCcy As String = "USD") As String
248
Dim Result As String
249
250
If Val(sNumber) = 0 Then Exit Function
251
sNumber = Right("000" & sNumber, 3)
252
253
If Mid(sNumber, 1, 1) <> "0" Then
254
Result = GetDigit(Mid(sNumber, 1, 1)) _
255
& sNWord(28)
256
If Mid(sNumber, 2, 2) <> "00" Then
257
Result = Result & sHWord(4)
258
End If
259
End If
260
261
If Mid(sNumber, 2, 1) <> "0" Then
262
Result = Result & GetTens(Mid(sNumber, 2), sLang, sCcy)
263
ElseIf Mid(sNumber, 3, 1) <> "0" Then
264
Result = Result & GetDigit(Mid(sNumber, 3))
265
End If
266
267
GetHundreds = Result
268
End Function
269
270
Private Function GetTens(TensText As String, _
271
Optional sLang As String = "English", _
272
Optional sCcy As String = "USD")
273
Dim Result As String
274
275
Result = ""
276
If Val(Left(TensText, 1)) = 1 Then '10-19...
277
If Val(TensText) > 9 And Val(TensText) < 20 Then
278
GetTens = sNWord(Val(TensText))
279
End If
280
Exit Function
281
Else '20-99...
282
If Val(Left(TensText, 1)) > 1 And _
283
Val(Left(TensText, 1)) < 10 Then
284
Result = sNWord(18 + Val(Left(TensText, 1)))
285
Else
286
Result = GetDigit(Right(TensText, 1))
287
End If
288
If Right(TensText, 1) <> "0" And Left(TensText, 1) <> "0" Then
289
Select Case sLang
290
Case "German"
291
Result = GetDigit(Right(TensText, 1)) & _
292
sHWord(4) & Result
293
Case "English"
294
Result = Result & GetDigit(Right(TensText, 1))
295
End Select
296
End If
297
End If
298
GetTens = Result
299
End Function
300
301
Private Function GetDigit(Digit As String) As String
302
If Val(Digit) < 10 Then
303
GetDigit = sNWord(Val(Digit))
304
Else
305
GetDigit = ""
306
End If
307
End Function
Copied!
sbSpellNumber.xlsm
28KB
Binary
sbSpellNumber.xlsm
Last modified 1yr ago
Copy link