DATOS

Son dos macros del tipo function, para ejecutarlas se debe convocar a la función clasificada en definida por el usuario y seleccionar np [=np(cell)].

 

Public Function np(R As Single) As String
Dim d1 As String
Dim d2 As String
Dim i, k As Integer
Dim R2, dif As Single
R2 = R * 10
dif = R2 - Fix(R2)
If dif >= 0.5 Then R2 = R2 + 1
R = Fix(R2) / 10
d1 = Format$(R, "0.0")
i = Val(Left$(d1, 1))
k = Val(Right$(d1, 1))
d1 = digito(i)
d2 = digito(k)
np = d1 + " coma " + d2
End Function
 

 

Function digito(ByVal j As Integer) As String
Select Case j
Case 1
digito = "uno"
Case 2
digito = "dos"
Case 3
digito = "tres"
Case 4
digito = "cuatro"
Case 5
digito = "cinco"
Case 6
digito = "seis"
Case 7
digito = "siete"
Case 8
digito = "ocho"
Case 9
digito = "nueve"
Case 0
digito = "cero"
End Select

End Function

Son dos macros del tipo function

Option Explicit
'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
ver archivo adjunto: numeros_a_letras.xls

Sub Ordenando()
'ordena la hoja Orden por la col A en forma ascendente teniendo la primera fila como encabezado
Sheets("Hoja1").Range("A1").Select
Selection.Sort key1:=Range("a1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub

Sub comparando()
‘Si las celdas coinciden se copia toda la fila en una tercer hoja.
copiada = 2
Sheets("Hoja1").Range("A2").Select
final = Range("A2").End(xlDown).Row
For fila = 2 To final
'compara la col 1 de la hoja1 y la col 2 de la hoja 2
If Cells(fila, 1) = ActiveSheet.Next.Cells(fila, 2).Value Then
ActiveCell.EntireRow.Copy Destination:=Sheets("Hoja3").Cells(copiada, 1)
ActiveSheet.Next.Cells(fila, 1).EntireRow.Copy Destination:=Sheets("Hoja3")._
Cells(copiada + 1, 1)
'quitar si no se copia lo de la hoja2
copiada = copiada + 2
'más 1 si no se copia lo de la hoja 2
End If
ActiveCell.Offset(1, 0).Select
Next
End Sub

Sub comparando()
‘Cada columna debe estar ordenada de menor a mayor
Dim fila1 As Integer, fila2 As Integer, fila3 As Integer
'compara a partir de la fila2, las columnas 1 y 2 de una misma hoja
fila1 = 2
fila2 = 2
fila3 = 2
Range("A2").Select
While Cells(fila1, 1).Value <> ""
'compara las col 1 y 2, copiando en la 4
If Cells(fila1, 1).Value = Cells(fila2, 2).Value Then
fila1 = fila1 + 1
fila2 = fila2 + 1
Cells(fila1, 1).Select
Else
If Cells(fila1, 1).Value < Cells(fila2, 2).Value Or Cells(fila2, 2).Value = "" Then
Cells(fila1, 1).Copy Destination:=Cells(fila3, 4)
fila3 = fila3 + 1
fila1 = fila1 + 1
Cells(fila1, 1).Select
Else
If Cells(fila2, 2).Value <> "" Then
Cells(fila2, 2).Copy Destination:=Cells(fila3, 4)
fila3 = fila3 + 1
fila2 = fila2 + 1
End If
End If
End If
Wend
While Cells(fila2, 2).Value <> ""
Cells(fila2, 2).Copy Destination:=Cells(fila3, 4)
fila3 = fila3 + 1
fila2 = fila2 + 1
Cells(fila2, 2).Select
Wend
End Sub