Excel macro: números a letras


/ Published in: Visual Basic
Save to your folder(s)

MS Excel Macro para escribir números en letras


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

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

Report this snippet


Comments

RSS Icon Subscribe to comments

You need to login to post a comment.