Ok, peguei o código da @EngineerToast e trabalhei com ele, já que, em princípio, ele está correto, mas falho (e não produz os resultados corretos). Eu não toquei o VBA em literalmente uma década, mas decidi dirigir aqui porque precisava disso para uma planilha.
Primeira ordem de trabalhos, precisamos de um Option Explicit no topo ! Nunca se preocupe em escrever uma única linha de código sem isso.
Isso resultou nesses tipos de erros, então eu apenas comentei as linhas que não estavam fazendo nada de qualquer maneira.
Mudeioprocessodesanitizaçãoparaumafunçãoseparada.Tudoissolidandocomseparadoresdecimaiseafinsnãodevesernecessário.Nóssóqueremososdígitos,entãotiramosoresto.
Depoisdetudoisso,ocódigoqueeuescreviaindaeradiferentedocódigoacima,maseuverifiqueiqueosresultadosqueestouobtendodaminhaversãocombinamcomoWolframAlphaecomalistagemdeNomesGrandesdeNomesdaWikipedia.
Tambémfuncionanospequenosnúmeros:
Deixe-mesaberseestouperdendoalgumacoisa.Issodeveserchamadopormeiodeumacélulacomaseguintefunção:
=NumberToName(TEXT(B8,"0"))
Onde B8 aqui é o valor numérico que você deseja converter. No meu caso, se B8 fosse "= 211 * (10 ^ 51)", o resultado de =NumberToName(TEXT(B8, "0")) seria:
Two Hundred Eleven Sedecillion
De qualquer forma, aqui está o código modificado:
Option Explicit
Public Function NumberToName(ByVal strNumber As String, Optional conversionCase As VbStrConv = vbProperCase) As String
' Remove seperators, white space, and anything else that is not needed
strNumber = ExtractNumbers(strNumber)
' Don't do anything if we don't have a anything
If (Len(strNumber) = 0) Then
Exit Function
End If
'Establish the arrays of name sections
Dim arrOnes: arrOnes = Array(Null, "one", "two", "three", "four", "five", "six", "seven", "eight", "nine", "ten", _
"eleven", "twelve", "thirteen", "fourteen", "fifteen", "sixteen", "seventeen", "eighteen", "nineteen")
Dim arrTens: arrTens = Array(Null, "", "twenty", "thirty", "forty", "fifty", "sixty", "seventy", "eighty", "ninety")
' Get our huge array of orders of magnitutde
Dim arrOrders() As String: arrOrders = GetMagnitudeArray()
Dim prefixIncrement As Integer: prefixIncrement = 1
Dim i As Long
Dim strName As String
'Process each chunk one at a time in reverse
For i = 1 To ((UBound(arrOrders) * 3) + 1) Step 3
'Break this chunk into pieces
Dim strPiece As String: strPiece = Mid(StrReverse(strNumber), i, 3)
'Check for zero
If (Val(strPiece) <> 0) Then
Dim strOne As String: strOne = Mid(strPiece, 1, 1)
Dim hasOnes As Boolean: hasOnes = (Val(strOne) > 0)
Dim strTen As String: strTen = Mid(strPiece, 2, 1)
Dim hasTens As Boolean: hasTens = (Val(strTen) > 0)
Dim strHundred As String: strHundred = Mid(strPiece, 3, 1)
Dim hasHundreds As Boolean: hasHundreds = (Val(strHundred) > 0)
'Add the order name
If ((prefixIncrement > 1) And (Len(strNumber) > 3)) Then
strName = arrOrders(prefixIncrement) & " " & strName
End If
'Add the teens name or the tens / ones names
If Val(strTen) <= 1 Then
strName = arrOnes(Val(strTen & strOne)) & " " & strName
ElseIf hasTens And Not hasOnes Then
strName = arrTens(Val(strTen)) & " " & 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
prefixIncrement = prefixIncrement + 1
Next
'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
strName = Replace(strName, " ", " ") 'Removes double spaces
'Return the number
NumberToName = strName
End Function
Private Function GetMagnitudeArray() As String()
Dim arrOrders(1 To 1005) As String
arrOrders(2) = "thousand": arrOrders(3) = "million": arrOrders(4) = "billion":
<SNIP etc etc>
GetMagnitudeArray = arrOrders()
End Function
Function ExtractNumbers(strText As String) As String
Dim i As Integer, outputString As String
For i = 1 To Len(strText)
If IsNumeric(Mid(strText, i, 1)) Then
outputString = outputString & Mid(strText, i, 1)
End If
Next i
ExtractNumbers = outputString
End Function