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/