Posted By

j_junyent on 12/02/07


Tagged

spanish macro excel


Versions (?)

Excel macro: números a letras


 / Published in: Visual Basic
 

URL: http://www.programacion.com/foros/32/msg/68141/

MS Excel Macro para escribir números en letras

  1. Sub NUMEROS_EN_LETRAS()
  2. Option Explicit
  3. 'Mauricio Baeza
  4. 'Samuel Monajaras
  5. 'Enero-97
  6. 'Ultima modificacion Octubre del 2002
  7. '[email protected]
  8. 'http://www.vbalym.netfirms.com
  9. 'Argumentos:
  10. 'Numero = Valor que deseamos convertir en texto
  11. 'Moneda = es el nombre de la moneda a mostrar
  12. 'Fraccion_Letras = Verdadero para que la fraccion de la moneda
  13. ' tambien la convierta a letras
  14. 'Fraccion = Es el nombre de la fraccion de la moneda
  15. 'Texto_Inicial = Cualquier texto que quieras al principio del resultado
  16. 'Texto_Final = Cualquier texto que quieras al finla del resultado
  17. 'Estilo = Formato de salida
  18. ' 1 = MAYUSCULAS
  19. ' 2 = minusculas
  20. ' 3 = Tipo Titulo
  21. 'Los valores negativos los convierte a positivos
  22. 'El valor minimo en 0, el valor maximo es 9,999,999,999,999.99
  23.  
  24. Public Function Numeros_Letras(ByVal Numero As Double, _
  25. ByVal Moneda As String, _
  26. Optional Fraccion_Letras As Boolean = False, _
  27. Optional Fraccion As String = "", _
  28. Optional Texto_Inicial As String = "", _
  29. Optional Texto_Final As String = "", _
  30. Optional Estilo As Integer = 1) As String
  31. Dim strLetras As String
  32. Dim NumTmp As String
  33. Dim intFraccion As Integer
  34.  
  35. strLetras = Texto_Inicial
  36. 'Convertimos a positivo si es negativo
  37. Numero = Abs(Numero)
  38. NumTmp = Format(Numero, "000000000000000.00")
  39. If Numero < 1 Then
  40. strLetras = strLetras & "cero " & Plural(Moneda) & " "
  41. Else
  42. strLetras = strLetras & NumLet(Val(Left(NumTmp, 15)))
  43. If Val(NumTmp) = 1 Or Val(NumTmp) < 2 Then
  44. strLetras = strLetras & Moneda & " "
  45. ElseIf Val(Mid(NumTmp, 4, 12)) = 0 Or Val(Mid(NumTmp, 10, 6)) = 0 Then
  46. strLetras = strLetras & "de " & Plural(Moneda) & " "
  47. Else
  48. strLetras = strLetras & Plural(Moneda) & " "
  49. End If
  50. End If
  51. If Fraccion_Letras Then
  52. intFraccion = Val(Right(NumTmp, 2))
  53. Select Case intFraccion
  54. Case 0
  55. strLetras = strLetras & "con cero " & Plural(Fraccion)
  56. Case 1
  57. strLetras = strLetras & "con un " & Fraccion
  58. Case Else
  59. strLetras = strLetras & "con " & NumLet(Val(Right(NumTmp, 2))) & Plural(Fraccion)
  60. End Select
  61. Else
  62. strLetras = strLetras & Right(NumTmp, 2)
  63. End If
  64. strLetras = strLetras & Texto_Final
  65. Select Case Estilo
  66. Case 1
  67. strLetras = StrConv(strLetras, vbUpperCase)
  68. Case 2
  69. strLetras = StrConv(strLetras, vbLowerCase)
  70. Case 3
  71. strLetras = StrConv(strLetras, vbProperCase)
  72. End Select
  73.  
  74. Numeros_Letras = strLetras
  75.  
  76. End Function
  77.  
  78. Public Function NumLet(ByVal Numero As Double) As String
  79. Dim NumTmp As String
  80. Dim co1 As Integer
  81. Dim co2 As Integer
  82. Dim pos As Integer
  83. Dim dig As Integer
  84. Dim cen As Integer
  85. Dim dec As Integer
  86. Dim uni As Integer
  87. Dim letra1 As String
  88. Dim letra2 As String
  89. Dim letra3 As String
  90. Dim Leyenda As String
  91. Dim TFNumero As String
  92.  
  93. NumTmp = Format(Numero, "000000000000000") 'Le da un formato fijo
  94. co1 = 1
  95. pos = 1
  96. TFNumero = ""
  97. 'Para extraer tres digitos cada vez
  98. Do While co1 <= 5
  99. co2 = 1
  100. Do While co2 <= 3
  101. 'Extrae un digito cada vez de izquierda a derecha
  102. dig = Val(Mid(NumTmp, pos, 1))
  103. Select Case co2
  104. Case 1: cen = dig
  105. Case 2: dec = dig
  106. Case 3: uni = dig
  107. End Select
  108. co2 = co2 + 1
  109. pos = pos + 1
  110. Loop
  111. letra3 = Centena(uni, dec, cen)
  112. letra2 = Decena(uni, dec)
  113. letra1 = Unidad(uni, dec)
  114.  
  115. Select Case co1
  116. Case 1
  117. If cen + dec + uni = 1 Then
  118. Leyenda = "billon "
  119. ElseIf cen + dec + uni > 1 Then
  120. Leyenda = "billones "
  121. End If
  122. Case 2
  123. If cen + dec + uni >= 1 And Val(Mid(NumTmp, 7, 3)) = 0 Then
  124. Leyenda = "mil millones "
  125. ElseIf cen + dec + uni >= 1 Then
  126. Leyenda = "mil "
  127. End If
  128. Case 3
  129. If cen + dec = 0 And uni = 1 Then
  130. Leyenda = "millon "
  131. ElseIf cen > 0 Or dec > 0 Or uni > 1 Then
  132. Leyenda = "millones "
  133. End If
  134. Case 4
  135. If cen + dec + uni >= 1 Then
  136. Leyenda = "mil "
  137. End If
  138. Case 5
  139. If cen + dec + uni >= 1 Then
  140. Leyenda = ""
  141. End If
  142. End Select
  143.  
  144. co1 = co1 + 1
  145. TFNumero = TFNumero + letra3 + letra2 + letra1 + Leyenda
  146.  
  147. Leyenda = ""
  148. letra1 = ""
  149. letra2 = ""
  150. letra3 = ""
  151. Loop
  152.  
  153. NumLet = TFNumero
  154.  
  155. End Function
  156.  
  157. Private Function Centena(ByVal uni As Integer, ByVal dec As Integer, _
  158. ByVal cen As Integer) As String
  159. Dim cTexto As String
  160.  
  161. Select Case cen
  162. Case 1
  163. If dec + uni = 0 Then
  164. cTexto = "cien "
  165. Else
  166. cTexto = "ciento "
  167. End If
  168. Case 2: cTexto = "doscientos "
  169. Case 3: cTexto = "trescientos "
  170. Case 4: cTexto = "cuatrocientos "
  171. Case 5: cTexto = "quinientos "
  172. Case 6: cTexto = "seiscientos "
  173. Case 7: cTexto = "setecientos "
  174. Case 8: cTexto = "ochocientos "
  175. Case 9: cTexto = "novecientos "
  176. Case Else: cTexto = ""
  177. End Select
  178. Centena = cTexto
  179.  
  180. End Function
  181.  
  182. Private Function Decena(ByVal uni As Integer, ByVal dec As Integer) As String
  183. Dim cTexto As String
  184.  
  185. Select Case dec
  186. Case 1:
  187. Select Case uni
  188. Case 0: cTexto = "diez "
  189. Case 1: cTexto = "once "
  190. Case 2: cTexto = "doce "
  191. Case 3: cTexto = "trece "
  192. Case 4: cTexto = "catorce "
  193. Case 5: cTexto = "quince "
  194. Case 6 To 9: cTexto = "dieci"
  195. End Select
  196. Case 2:
  197. If uni = 0 Then
  198. cTexto = "veinte "
  199. ElseIf uni > 0 Then
  200. cTexto = "veinti"
  201. End If
  202. Case 3: cTexto = "treinta "
  203. Case 4: cTexto = "cuarenta "
  204. Case 5: cTexto = "cincuenta "
  205. Case 6: cTexto = "sesenta "
  206. Case 7: cTexto = "setenta "
  207. Case 8: cTexto = "ochenta "
  208. Case 9: cTexto = "noventa "
  209. Case Else: cTexto = ""
  210. End Select
  211.  
  212. If uni > 0 And dec > 2 Then cTexto = cTexto + "y "
  213.  
  214. Decena = cTexto
  215.  
  216. End Function
  217.  
  218. Private Function Unidad(ByVal uni As Integer, ByVal dec As Integer) As String
  219. Dim cTexto As String
  220.  
  221. If dec <> 1 Then
  222. Select Case uni
  223. Case 1: cTexto = "un "
  224. Case 2: cTexto = "dos "
  225. Case 3: cTexto = "tres "
  226. Case 4: cTexto = "cuatro "
  227. Case 5: cTexto = "cinco "
  228. End Select
  229. End If
  230. Select Case uni
  231. Case 6: cTexto = "seis "
  232. Case 7: cTexto = "siete "
  233. Case 8: cTexto = "ocho "
  234. Case 9: cTexto = "nueve "
  235. End Select
  236.  
  237. Unidad = cTexto
  238.  
  239. End Function
  240.  
  241. 'Funcion que convierte al plural el argumento pasado
  242. Private Function Plural(ByVal Palabra As String) As String
  243. Dim pos As Integer
  244. Dim strPal As String
  245.  
  246. If Len(Trim(Palabra)) > 0 Then
  247. pos = InStr(1, "aeiou", Right(Palabra, 1), vbTextCompare)
  248. If pos > 0 Then
  249. strPal = Palabra & "s"
  250. Else
  251. strPal = Palabra & "es"
  252. End If
  253. End If
  254. Plural = strPal
  255.  
  256. End Function

Report this snippet  

Comments

RSS Icon Subscribe to comments
Posted By: pediwn on May 21, 2008

de hora a letra?

You need to login to post a comment.