Ответ часть 1 из 3
Этот ответ публикуется в трех частях из-за ограничения по количеству символов
РЕДАКТИРОВАТЬ: Основываясь на переработке моего оригинального ответа Патрик, я пересмотрел свой собственный код и сделал некоторые улучшения. В частности, я ужесточил обработку десятичных значений.
Ну, совершенно случайный ОП, о котором я ничего не знаю, вам повезло! У меня была пугающе похожая потребность, и я написал для этого функцию VBA. Как таковой, он может обрабатывать любое число до 10 ^ {+/- 3,012}, но его можно увеличить или уменьшить по желанию.
Важно, чтобы число передавалось в виде строки. Это единственный способ, с помощью которого Excel может обрабатывать такие большие числа, не переводя их в научную запись.
Option Explicit
Public Function SpellNumber(ByVal arabicNumberString As String, Optional conversionCase As VbStrConv = vbProperCase) As String
'Spells out a number in English (uses the Short Scale names)
'If you try to use a very large number, you must convert it to a string before sending it
'Otherwise, Excel may convert it to scientific notation before passing it to the VBA
'You can do this with the TEXT formula such as TEXT(A1,"0")
'Orders of Magnitude: (negative powers of ten can be inferred by symmetry and adding "th(s)")
'Words Power Decimal
'------------------------------------------
'One 10^0 1 (not used when writing numbers as words)
'Ten 10^1 10 (not used when writing numbers as words)
'Hundred 10^2 100
'Thousand 10^3 1,000
'Million 10^6 1,000,000
'Billion 10^9 1,000,000,000
'Trillion 10^12 1,000,000,000,000
'Quadrillion 10^15 1,000,000,000,000,000
'Quintillion 10^18 1,000,000,000,000,000,000
'Sextillion 10^21 1,000,000,000,000,000,000,000
'Septillion 10^24 1,000,000,000,000,000,000,000,000
'Octillion 10^27 1,000,000,000,000,000,000,000,000,000
'Nonillion 10^30 (Meaningless to show in decimal form but the pattern continues)
'Decillion 10^33
'Undecillion 10^36
'Duodecillion 10^39
'Tredecillion 10^42
'Continue this list: http://www.olsenhome.com/bignumbers/
'Constants
Const validCharacters = "0123456789.-" 'Characters that are valid numerically
'Declarations
Dim strNumber As String
Dim strName As String
Dim strLeft As String, strRight As String
Dim strPiece As String
Dim strOne As String, strTen As String, strHundred As String
Dim arrOnes, arrTens, arrOrders() As String, valOrder As Integer
Dim i As Long
Dim invalidNumber As Boolean
'Store the input as a separate variable and remove any digit grouping
strNumber = arabicNumberString
strNumber = Replace(strNumber, application.ThousandsSeparator, "")
'Check for errors (negative sign in the middle, more than one decimal point, any non-numeric characters)
If InStr(2, strNumber, "-") > 1 Then invalidNumber = True
If (Len(strNumber) - Len(Replace(strNumber, application.DecimalSeparator, ""))) > 1 Then invalidNumber = True
For i = 1 To Len(strNumber)
If InStr(1, validCharacters, Mid(strNumber, i, 1)) = 0 Then invalidNumber = True
Next
If invalidNumber Then SpellNumber = "(Not a valid number)": Exit Function
'Remove the negative sign (it'll be checked later from the original input)
If Left(strNumber, 1) = "-" Then strNumber = Mid(strNumber, 2)
'Establish the arrays of name sections
arrOnes = Array(Null, "one", "two", "three", "four", "five", "six", "seven", "eight", "nine", "ten", _
"eleven", "twelve", "thirteen", "fourteen", "fifteen", "sixteen", "seventeen", "eighteen", "nineteen")
arrTens = Array(Null, "", "twenty", "thirty", "forty", "fifty", "sixty", "seventy", "eighty", "ninety")
arrOrders = CreateArrOrders() 'Large and clumsy so it gets it's own function
'Break it in half if it has a decimal place
If InStr(1, strNumber, application.DecimalSeparator) > 0 Then
strLeft = Left(strNumber, InStr(1, strNumber, application.DecimalSeparator) - 1)
strRight = Mid(strNumber, InStr(1, strNumber, application.DecimalSeparator) + 1)
Else
strLeft = strNumber
strRight = ""
End If
'Remove leading and trailing zeroes
Do Until Left(strLeft, 1) <> "0"
strLeft = Mid(strLeft, 2)
Loop
Do Until Right(strRight, 1) <> "0"
strRight = Left(strRight, Len(strRight) - 1)
Loop
'Check if the number is too large on either side
If ((Len(strLeft) - 1) / 3) > UBound(arrOrders) Or ((Len(strLeft) - 1) / 3) > UBound(arrOrders) Then
SpellNumber = "Outside scope: Max 10^{± " & Format(UBound(arrOrders) * 3 - 3, "#" & application.ThousandsSeparator & "##0")
SpellNumber = SpellNumber & "} [" & StrConv(arrOrders(UBound(arrOrders)), vbProperCase) & "(ths)]"
Exit Function
End If
'Process the piece to the left of the decimal if it exists and isn't zero
If Len(strLeft) > 0 Then
If Len(Replace(strLeft, "0", "")) > 0 Then
'Process each chunk one at a time in reverse
valOrder = 1
For i = 1 To UBound(arrOrders) * 3 + 1 Step 3
'Break this chunk into pieces
strPiece = Mid(StrReverse(strLeft), i, 3)
strOne = Mid(strPiece, 1, 1)
strTen = Mid(strPiece, 2, 1)
strHundred = Mid(strPiece, 3, 1)
'Check for zero
If Val(strPiece) <> 0 Then
'Add the order name
If valOrder > 1 Then strName = arrOrders(valOrder) & " " & strName
'Add the teens name or the tens / ones names
If Val(strTen) <= 1 Then
strName = arrOnes(Val(strTen & strOne)) & " " & strName
Else
strName = arrTens(Val(strTen)) & "-" & arrOnes(Val(strOne)) & " " & strName
End If
'Add the hundreds name
If Val(strHundred) > 0 Then
strName = arrOnes(Val(strHundred)) & " hundred " & strName
End If
End If
'Exit Early
If i > Len(strLeft) Then Exit For
'Increment
valOrder = valOrder + 1
Next
End If
End If
'Process the piece to the right of the decimal if it exists and isn't zero
If Len(strRight) > 0 Then
If Len(Replace(strRight, "0", "")) > 0 Then
'Add the decimal designator
strName = strName & " and "
'Check for small values
If Len(strRight) = 1 Then
strName = strName & arrOnes(Val(strRight)) & " tenth"
If strRight <> "1" Then strName = strName & "s"
ElseIf Len(strRight) = 2 Then
strName = strName & SpellNumber(strRight) & " hundredths"
Else
strName = strName & SpellNumber(strRight)
valOrder = Len(strRight) + 1
valOrder = (valOrder - (valOrder Mod 3)) / 3 + 1
strName = strName & " " & arrOrders(valOrder) & "ths"
End If
End If
End If
'Establish if it's negative
If Left(arabicNumberString, 1) = "-" Then strName = "Negative " & strName
'Cleanup
strName = Replace(strName, "- ", " ") 'Removes err when tens > 1 and ones = 0 (e.g. "twenty-")
strName = Trim(strName) 'Removes leading and trailing spaces just in case
strName = StrConv(strName, conversionCase) 'Applies casing to the string
Do Until InStr(1, strName, " ") = 0
strName = Replace(strName, " ", " ") 'Removes double spaces just in case
Loop
'Return the number
SpellNumber = strName
End Function
Private Function CreateArrOrders() As String()
Dim arrOrders(1 To 1005) As String
arrOrders(2) = "thousand": arrOrders(3) = "million": arrOrders(4) = "billion": arrOrders(5) = "trillion": arrOrders(6) = "quadrillion": arrOrders(7) = "quintillion": arrOrders(8) = "sextillion": arrOrders(9) = "septillion": arrOrders(10) = "octillion": arrOrders(11) = "nonillion": arrOrders(12) = "decillion": arrOrders(13) = "undecillion": arrOrders(14) = "duodecillion": arrOrders(15) = "tredecillion":
'Et cetera based on the source list / other answers. Too long to fit all in one posting on SuperUser.
CreateArrOrders = arrOrders()
End Function