Revision: 4370
Initial Code
Initial URL
Initial Description
Initial Title
Initial Tags
Initial Language
at December 2, 2007 12:55 by j_junyent
Initial Code
Sub NUMEROS_EN_LETRAS() Option Explicit 'Mauricio Baeza 'Samuel Monajaras 'Enero-97 'Ultima modificacion Octubre del 2002 '[email protected] 'http://www.vbalym.netfirms.com 'Argumentos: 'Numero = Valor que deseamos convertir en texto 'Moneda = es el nombre de la moneda a mostrar 'Fraccion_Letras = Verdadero para que la fraccion de la moneda ' tambien la convierta a letras 'Fraccion = Es el nombre de la fraccion de la moneda 'Texto_Inicial = Cualquier texto que quieras al principio del resultado 'Texto_Final = Cualquier texto que quieras al finla del resultado 'Estilo = Formato de salida ' 1 = MAYUSCULAS ' 2 = minusculas ' 3 = Tipo Titulo 'Los valores negativos los convierte a positivos 'El valor minimo en 0, el valor maximo es 9,999,999,999,999.99 Public Function Numeros_Letras(ByVal Numero As Double, _ ByVal Moneda As String, _ Optional Fraccion_Letras As Boolean = False, _ Optional Fraccion As String = "", _ Optional Texto_Inicial As String = "", _ Optional Texto_Final As String = "", _ Optional Estilo As Integer = 1) As String Dim strLetras As String Dim NumTmp As String Dim intFraccion As Integer strLetras = Texto_Inicial 'Convertimos a positivo si es negativo Numero = Abs(Numero) NumTmp = Format(Numero, "000000000000000.00") If Numero < 1 Then strLetras = strLetras & "cero " & Plural(Moneda) & " " Else strLetras = strLetras & NumLet(Val(Left(NumTmp, 15))) If Val(NumTmp) = 1 Or Val(NumTmp) < 2 Then strLetras = strLetras & Moneda & " " ElseIf Val(Mid(NumTmp, 4, 12)) = 0 Or Val(Mid(NumTmp, 10, 6)) = 0 Then strLetras = strLetras & "de " & Plural(Moneda) & " " Else strLetras = strLetras & Plural(Moneda) & " " End If End If If Fraccion_Letras Then intFraccion = Val(Right(NumTmp, 2)) Select Case intFraccion Case 0 strLetras = strLetras & "con cero " & Plural(Fraccion) Case 1 strLetras = strLetras & "con un " & Fraccion Case Else strLetras = strLetras & "con " & NumLet(Val(Right(NumTmp, 2))) & Plural(Fraccion) End Select Else strLetras = strLetras & Right(NumTmp, 2) End If strLetras = strLetras & Texto_Final Select Case Estilo Case 1 strLetras = StrConv(strLetras, vbUpperCase) Case 2 strLetras = StrConv(strLetras, vbLowerCase) Case 3 strLetras = StrConv(strLetras, vbProperCase) End Select Numeros_Letras = strLetras End Function Public Function NumLet(ByVal Numero As Double) As String Dim NumTmp As String Dim co1 As Integer Dim co2 As Integer Dim pos As Integer Dim dig As Integer Dim cen As Integer Dim dec As Integer Dim uni As Integer Dim letra1 As String Dim letra2 As String Dim letra3 As String Dim Leyenda As String Dim TFNumero As String NumTmp = Format(Numero, "000000000000000") 'Le da un formato fijo co1 = 1 pos = 1 TFNumero = "" 'Para extraer tres digitos cada vez Do While co1 <= 5 co2 = 1 Do While co2 <= 3 'Extrae un digito cada vez de izquierda a derecha dig = Val(Mid(NumTmp, pos, 1)) Select Case co2 Case 1: cen = dig Case 2: dec = dig Case 3: uni = dig End Select co2 = co2 + 1 pos = pos + 1 Loop letra3 = Centena(uni, dec, cen) letra2 = Decena(uni, dec) letra1 = Unidad(uni, dec) Select Case co1 Case 1 If cen + dec + uni = 1 Then Leyenda = "billon " ElseIf cen + dec + uni > 1 Then Leyenda = "billones " End If Case 2 If cen + dec + uni >= 1 And Val(Mid(NumTmp, 7, 3)) = 0 Then Leyenda = "mil millones " ElseIf cen + dec + uni >= 1 Then Leyenda = "mil " End If Case 3 If cen + dec = 0 And uni = 1 Then Leyenda = "millon " ElseIf cen > 0 Or dec > 0 Or uni > 1 Then Leyenda = "millones " End If Case 4 If cen + dec + uni >= 1 Then Leyenda = "mil " End If Case 5 If cen + dec + uni >= 1 Then Leyenda = "" End If End Select co1 = co1 + 1 TFNumero = TFNumero + letra3 + letra2 + letra1 + Leyenda Leyenda = "" letra1 = "" letra2 = "" letra3 = "" Loop NumLet = TFNumero End Function Private Function Centena(ByVal uni As Integer, ByVal dec As Integer, _ ByVal cen As Integer) As String Dim cTexto As String Select Case cen Case 1 If dec + uni = 0 Then cTexto = "cien " Else cTexto = "ciento " End If Case 2: cTexto = "doscientos " Case 3: cTexto = "trescientos " Case 4: cTexto = "cuatrocientos " Case 5: cTexto = "quinientos " Case 6: cTexto = "seiscientos " Case 7: cTexto = "setecientos " Case 8: cTexto = "ochocientos " Case 9: cTexto = "novecientos " Case Else: cTexto = "" End Select Centena = cTexto End Function Private Function Decena(ByVal uni As Integer, ByVal dec As Integer) As String Dim cTexto As String Select Case dec Case 1: Select Case uni Case 0: cTexto = "diez " Case 1: cTexto = "once " Case 2: cTexto = "doce " Case 3: cTexto = "trece " Case 4: cTexto = "catorce " Case 5: cTexto = "quince " Case 6 To 9: cTexto = "dieci" End Select Case 2: If uni = 0 Then cTexto = "veinte " ElseIf uni > 0 Then cTexto = "veinti" End If Case 3: cTexto = "treinta " Case 4: cTexto = "cuarenta " Case 5: cTexto = "cincuenta " Case 6: cTexto = "sesenta " Case 7: cTexto = "setenta " Case 8: cTexto = "ochenta " Case 9: cTexto = "noventa " Case Else: cTexto = "" End Select If uni > 0 And dec > 2 Then cTexto = cTexto + "y " Decena = cTexto End Function Private Function Unidad(ByVal uni As Integer, ByVal dec As Integer) As String Dim cTexto As String If dec <> 1 Then Select Case uni Case 1: cTexto = "un " Case 2: cTexto = "dos " Case 3: cTexto = "tres " Case 4: cTexto = "cuatro " Case 5: cTexto = "cinco " End Select End If Select Case uni Case 6: cTexto = "seis " Case 7: cTexto = "siete " Case 8: cTexto = "ocho " Case 9: cTexto = "nueve " End Select Unidad = cTexto End Function 'Funcion que convierte al plural el argumento pasado Private Function Plural(ByVal Palabra As String) As String Dim pos As Integer Dim strPal As String If Len(Trim(Palabra)) > 0 Then pos = InStr(1, "aeiou", Right(Palabra, 1), vbTextCompare) If pos > 0 Then strPal = Palabra & "s" Else strPal = Palabra & "es" End If End If Plural = strPal End Function
Initial URL
http://www.programacion.com/foros/32/msg/68141/
Initial Description
MS Excel Macro para escribir números en letras
Initial Title
Excel macro: números a letras
Initial Tags
excel
Initial Language
Visual Basic