Abaixo a função para escrever valores monetários por extenso limitada à **999 trilhões**, creio que com ela poderá adequar seu código para escrever número não monetários também: Function VALOREXTENSO(valor As Double) As String ' ' Escreve o valor por extenso ' Dim strMoeda As String Dim negative As String Dim cents As Variant Dim decimalSep As String ' Verifica se o número é positivo ou negativo If valor < 0 Then valor = valor * (-1) negative = "(-) menos " Else negative = "" End If ' Se o valor for igual ou maior que 1 quatrilhao ' passar erro e sair da funcao If valor > 999999999999999# Then VALOREXTENSO = "[erro] Valor excede 999.999.999.999.999" Exit Function End If ' Se valor for igual a 1, a unidade está no singular If WorksheetFunction.RoundDown(valor, 0) = 1 Then ' a string da moeda no singular strMoeda = " real" ' Se for maior que 1 a unidade está no plural ElseIf WorksheetFunction.RoundDown(valor, 0) > 1 Then strMoeda = " reais" End If ' Remove os centavos cents = valor - WorksheetFunction.RoundDown(valor, 0) ' Remove os centavos do valor valor = valor - CDbl(cents) ' Passo o extenso dos centavos cents = Centavos(CDbl(cents) * 100) ' End If ' Caso a string seja diferente de branco e valor seja maior ou igual a 1 If cents <> "" And valor >= 1 Then ' acrescentar uma vírgula antes do extenso cents = " e " & cents End If ' Iniciar o processo de conversao dos valores longos strMoeda = Trim(Trilhoes(valor)) & strMoeda & cents strMoeda = Replace(strMoeda, ", e", " e") strMoeda = Replace(strMoeda, ", r", " r") If Left(strMoeda, 2) = "e " Then strMoeda = Mid(strMoeda, 3, Len(strMoeda)) 'ElseIf Left(strMoeda, 5) = "mil e" Then ' strMoeda = Mid(strMoeda, 5, Len(strMoeda)) End If vzz = "00000000000000000000" vtam = Len(Trim(Mid(Trim(valor), 2, 100))) If Right(vzz + vzz + vzz + vzz, vtam) = Mid(Trim(valor), 2, 100) And InStr(UCase(strMoeda), UCase("es ")) > 0 Then vetor = Split(strMoeda, " ") vtrocar = vetor(UBound(vetor)) strMoeda = Replace(strMoeda, vtrocar, "de " + vtrocar) End If If negative <> "" Then VALOREXTENSO = negative & strMoeda Else VALOREXTENSO = strMoeda End If End Function Private Function Centavos(valor As Double) As String Dim dezena As Integer Dim unidade As Integer ' Passa o valor para base decimal valor = Round(CDbl(valor / 100), 2) ' Se for um centavo, escrever valor e sair da funcao If valor = 0.01 Then Centavos = "um centavo" Exit Function End If ' Repassa valor para dezenas valor = valor * 100 ' Se nao houver dezenas no valor passado If Dezenas(valor) = "" Then ' a string centavos fica em branco Centavos = "" Else ' caso contrário, passar extenso das dezenas e concatenar ' com a palavra centavos Centavos = Dezenas(valor) & " centavos" End If End Function Private Function Unidades(unidade As Double) As String Dim Unid(9) ' Define as unidades a serem usadas Unid(1) = "um": Unid(6) = "seis" Unid(2) = "dois": Unid(7) = "sete" Unid(3) = "três": Unid(8) = "oito" Unid(4) = "quatro": Unid(9) = "nove" Unid(5) = "cinco" ' Retorna a string referente a unidade passada para ' esta funcao Unidades = Trim(Unid(unidade)) End Function Private Function Dezenas(dezena As Double) As String Dim dezes(9) Dim dez(9) Dim intDezena As Double Dim intUnidade As Double Dim tmpStr As String ' Define as dezenas a serem utilizadas dezes(1) = "onze": dezes(6) = "dezesseis" dezes(2) = "doze": dezes(7) = "dezessete" dezes(3) = "treze": dezes(8) = "dezoito" dezes(4) = "quatorze": dezes(9) = "dezenove" dezes(5) = "quinze" dez(1) = "dez": dez(6) = "sessenta" dez(2) = "vinte": dez(7) = "setenta" dez(3) = "trinta": dez(8) = "oitenta" dez(4) = "quarenta": dez(9) = "noventa" dez(5) = "cinquenta" ' Calcula o inteiro da dezena intDezena = Int(dezena / 10) ' Calcula o inteiro da unidade intUnidade = dezena Mod 10 ' Se o inteiro da dezena for zero If intDezena = 0 Then ' dezenas sao iguais as unidades Dezenas = Unidades(intUnidade) Exit Function Else: ' caso contrário, é igual a dez Dezenas = dez(intDezena) End If ' Se o inteiro da dezena for igual a 1 e ' o inteiro da unidade for zero, os valores estao ' entre 11 e 19 If (intDezena = 1 And intUnidade > 0) Then Dezenas = dezes(intUnidade) Else ' Caso contrário, valor está entre 20 e 90 inclusive If (intDezena > 1 And intUnidade > 0) Then ' Concatena a string da dezena com a string da unidade Dezenas = Dezenas & " e " & Unidades(intUnidade) End If End If Dezenas = Dezenas End Function Private Function Centenas(centena As Double) As String Dim tmpCento As Double Dim tmpDez As Double Dim tmpUni As Double Dim tmpUniMod As Double Dim tmpModDez As Double Dim centoString As String Dim Cento(9) ' Define as centenas Cento(1) = "cento": Cento(6) = "seiscentos" Cento(2) = "duzentos": Cento(7) = "setecentos" Cento(3) = "trezentos": Cento(8) = "oitocentos" Cento(4) = "quatrocentos": Cento(9) = "novecentos" Cento(5) = "quinhentos" ' Calcula o inteiro da centena tmpCento = Int(centena / 100) ' Calcula a parte da dezena tmpDez = centena - (tmpCento * 100) ' Calcula o inteiro da unidade tmpUni = Int(tmpDez / 10) ' Calcula o resto da unidade tmpUniMod = tmpUni Mod 10 ' Calcula o resto da dezena tmpModDez = tmpDez Mod 10 ' Se centena for cem, definir string como "cem " e sair If centena = 100 Then centoString = "cem " Else ' Caso contrário definir a string da centena centoString = Cento(tmpCento) End If ' Avalia se a unidade é maior ou igual a zero, se o resto da unidade é igual ou ' maior que zero, se a dezena é maior ou igual a um e se a centena é igual ou ' maior que 1. Se forem verdadeiros; entao, adicionar " e " a string da centena If (tmpUni >= 0 And tmpUniMod >= 0 And tmpDez >= 1 And tmpCento >= 1) Then centoString = centoString & " e " End If ' Concatena a string do cento com a string da dezena Centenas = Trim(centoString & Dezenas(tmpDez)) End Function Private Function Milhares(milhar As Double) As String Dim tmpMilhar As Double Dim tmpCento As Double Dim milString As String ' Calcula o inteiro da milhar tmpMilhar = Int(milhar / 1000) ' Calcula o cento dentro da milhar tmpCento = milhar - (tmpMilhar * 1000) ' Se milhar for zero, entao a string da milhar fica em branco If tmpMilhar = 0 Then milString = "" ' Se for igual a 1, entao ' If '(tmpMilhar = 1) Then ' string da milhar é igual a unidade e "mil" 'milString = unidades(tmpMilhar) & "um mil " ' se maior que 1 e menor que dez, string igual a unidades If (tmpMilhar >= 1 And tmpMilhar < 10) Then milString = Unidades(tmpMilhar) & " mil, " ' Se for entre 10 e 100, entao string igual a dezenas ElseIf (tmpMilhar >= 10 And tmpMilhar < 100) Then milString = Dezenas(tmpMilhar) & " mil, " ' Se for entre 100 e 1000, entao igual string centenas ElseIf (tmpMilhar >= 100 And tmpMilhar < 1000) Then milString = Centenas(tmpMilhar) & " mil, " End If 'If tmpCento = 1 Then milString = " e " If (tmpCento >= 1 And tmpCento <= 100) Then milString = milString & "e " Milhares = Trim(milString & Centenas(tmpCento)) End Function Private Function milhoes(milhao As Double) As String ' Ver comentários para milhares acima Dim tmpMilhao As Double Dim tmpMilhares As Double Dim miString As String tmpMilhao = Int(milhao / 1000000) tmpMilhares = milhao - (tmpMilhao * 1000000) If tmpMilhao = 0 Then miString = "" If (tmpMilhao = 1) Then miString = Unidades(tmpMilhao) & " milhão, " ElseIf (tmpMilhao > 1 And tmpMilhao < 10) Then miString = Unidades(tmpMilhao) & " milhões, " ElseIf (tmpMilhao >= 10 And tmpMilhao < 100) Then miString = Dezenas(tmpMilhao) & " milhões, " ElseIf (tmpMilhao >= 100 And tmpMilhao < 1000) Then miString = Centenas(tmpMilhao) & " milhões, " End If If milhao = 1000000# Then miString = "um milhão de " milhoes = Trim(miString & Milhares(tmpMilhares)) End Function Private Function bilhoes(bilhao As Double) As String ' Ver comentários para milhares acima Dim tmpBilhao As Double Dim tmpMilhao As Double 'Dim tmpMilhoes As Double Dim biString As String tmpBilhao = Int(bilhao / 1000000000) tmpMilhao = bilhao - (tmpBilhao * 1000000000) If (tmpBilhao = 1) Then biString = Unidades(tmpBilhao) & " bilhão, " ElseIf (tmpBilhao > 1 And tmpBilhao < 10) Then biString = Unidades(tmpBilhao) & " bilhões, " ElseIf (tmpBilhao >= 10 And tmpBilhao < 100) Then biString = Dezenas(tmpBilhao) & " bilhões, " ElseIf (tmpBilhao >= 100 And tmpBilhao < 1000) Then biString = Centenas(tmpBilhao) & " bilhões, " End If If bilhao = 1000000000# Then biString = "um bilhão de " bilhoes = Trim(biString & milhoes(tmpMilhao)) End Function Private Function Trilhoes(Trilhao As Double) As String ' Ver comentários para milhares acima Dim tmpTrilhao As Double Dim tmpBilhao As Double Dim triString As String tmpTrilhao = Int(Trilhao / 1000000000000#) tmpBilhao = Trilhao - (tmpTrilhao * 1000000000000#) If (tmpTrilhao = 1) Then triString = Unidades(tmpTrilhao) & " trilhão, " ElseIf (tmpTrilhao > 1 And tmpTrilhao < 10) Then triString = Unidades(tmpTrilhao) & " trilhões, " ElseIf (tmpTrilhao >= 10 And tmpTrilhao < 100) Then triString = Dezenas(tmpTrilhao) & " trilhões, " ElseIf (tmpTrilhao >= 100 And tmpTrilhao < 1000) Then triString = Centenas(tmpTrilhao) & " trilhões, " End If If Trilhao = 1000000000000# Then triString = "um trilhão de " Trilhoes = Trim(triString & bilhoes(tmpBilhao)) End Function Function ARREDBAIXO(valor) Dim tmpValor tmpValor = Round(CDbl(Right(Round(valor, 2) * 100, 2)) / 100, 2) ARREDBAIXO = Round(Round(valor, 2) - tmpValor, 0) End Function Planilha de exemplo se encontra [aqui.][1] Espero ter ajudado. [1]: http://excelguru.com.br/excel-2/escrever-por-extenso/