Código da Fórmula Extenso do Excell

Function Extenso(dValor AsDouble) AsString
Dim sMoeda AsString
Dim dCents AsVariant

'Se o valor for igual ou maior que 1 quatrilhão
'não será possível proceder com a função
If dValor > 999999999999999# Then Extenso = "valor muito grande"
ExitFunction
EndIf

'Se o valor for menor que 1 centavo, considerar-se-á zero para a função:
If dValor < 0.01 Then Extenso = "zero reais"
ExitFunction
EndIf

'Se o valor da unidade for igual a 1, a unidade está no singular
'Caso contrário, estará no plural.
If Fix(dValor) = 1 Then sMoeda = " real"
Else
sMoeda = " reais"
EndIf

'Remove os centavos dCents = dValor - Fix(dValor)

'Remove os centavos do valor dValor = dValor - CDbl(dCents)

'Chamar função de extenso para os centavos dCents = Centavos(CDbl(dCents) * 100)

'Caso a string seja diferente de branco e valor seja maior ou igual a 1
If dCents vbNullString And dValor >= 1 Then
'acrescentar uma vírgula antes do extenso dCents = " e "& dCents
EndIf
'Iniciar o processo de conversao dos valores longos sMoeda = Trim(Trilhões(dValor)) & sMoeda & dCents sMoeda = Replace(sMoeda, ", e", " e") sMoeda = Replace(sMoeda, ", r", " r")
If Left(sMoeda, 2) = "e "Then sMoeda = Mid(sMoeda, 3, Len(sMoeda))
'ElseIf Left(sMoeda, 5) = "mil e" Then
'sMoeda = Mid(sMoeda, 5, Len(sMoeda))
EndIf
Extenso = sMoeda
EndFunction

PrivateFunction Centavos(dValor AsDouble) AsString

'Passa o valor para base decimal dValor = Round(CDbl(dValor / 100), 2)

'Se for um centavo, escrever valor e sair da função
If dValor = 0.01 Then Centavos = "um centavo"
ExitFunction
EndIf

'Repassa valor para dezenas dValor = dValor * 100

'Se nao houver dezenas no valor passado
If Dezenas(dValor) = vbNullString Then
'a string centavos fica em branco Centavos = vbNullString
Else
'caso contrário, passar extenso das dezenas e concatenar
'com a palavra centavos