Modificar código de Macro Números a Texto (Dolar)

winnerclip · el 7 de septiembre

Modificar Código Macro Numeros a Texto.

Amigos, hace ya un tiempo consulte por una macro que muestra el texto de un número determinado. ( en ingles, Dolar ), me enviaron un ejemplo, el cual a la fecha no lo he podido modificar para mejorarlo de acuerdo a los requerimientos de mi trabajo.

Por esta razón es que nuevamente le solicito a ustedes puedan ayudarme con esta macro.

Adjunto planilla de ejemplo, donde se muestra como lo escriben (texto) manualmente y como muestra con la macro.

de ante mano muchas gracias por vuestra ayuda.

Winnerclip

macro_num_a_texto_en_Ingles.xls

Bernar2 · el 7 de septiembre

si te sirve a mi me paso esto mismo pero en español cuando estaba haciendo un Formato de Factura pero en Cristal Report bajo Basic, lo que hice fue crear el codigo del centabo aparte del Dolar usando casi el mismo codigo. Luegos los uni con un IF:

if {@MontoCentavosEscrito}>"0" then
{@MontoDolaresEscrito} + "CON " + {@MontoCentavosEscrito}
else
{@MontoDolaresEscrito}[/code]

Saludos.

joshua · el 7 de septiembre

Saludos.

Prueba y comentas.

'Funcion para convertir los numeros a caracteres.


Function Num_texto(Numero)
    Dim Texto
    Dim Millones
    Dim Miles
    Dim Cientos
    Dim Decimales
    Dim Cadena
    Dim CadMillones
    Dim CadMiles
    Dim CadCientos
    Texto = Numero
    Texto = FormatNumber(Texto, 2)
    Texto = Right(Space(14) & Texto, 14)
    Millones = Mid(Texto, 1, 3)
    Miles = Mid(Texto, 5, 3)
    Cientos = Mid(Texto, 9, 3)
    Decimales = Mid(Texto, 13, 2)
    CadMillones = ConvierteCifra(Millones, 1)
    CadMiles = ConvierteCifra(Miles, 1)
    CadCientos = ConvierteCifra(Cientos, 0)
    If Trim(CadMillones) > "" Then
        If Trim(CadMillones) = "UN" Then
            Cadena = CadMillones & " MILLON"
        Else
            Cadena = CadMillones & " MILLONES"
        End If
    End If
    If Trim(CadMiles) > "" Then
        Cadena = Cadena & " " & CadMiles & " MIL"
    End If
    If Trim(CadMiles & CadCientos) = "UN" Then
        Cadena = Cadena & "UNO CON " & Decimales & "/100"
    Else
        If Miles & Cientos = "000000" Then
            Cadena = Cadena & " " & Trim(CadCientos) & " " & Decimales & "/100"
        Else
            Cadena = Cadena & " " & Trim(CadCientos) & " " & Decimales & "/100"
        End If
    End If
    Num_texto = Trim(Cadena)
End Function

Function ConvierteCifra(Texto, SW)
    Dim Centena
    Dim Decena
    Dim Unidad
    Dim txtCentena
    Dim txtDecena
    Dim txtUnidad
    Centena = Mid(Texto, 1, 1)
    Decena = Mid(Texto, 2, 1)
    Unidad = Mid(Texto, 3, 1)
    Select Case Centena
        Case "1"
            txtCentena = "CIEN"
            If Decena & Unidad <> "00" Then
                txtCentena = "CIENTO"
            End If
        Case "2"
            txtCentena = "DOSCIENTOS"
        Case "3"
            txtCentena = "TRESCIENTOS"
        Case "4"
            txtCentena = "CUATROCIENTOS"
        Case "5"
            txtCentena = "QUINIENTOS"
        Case "6"
            txtCentena = "SEISCIENTOS"
        Case "7"
            txtCentena = "SETECIENTOS"
        Case "8"
            txtCentena = "OCHOCIENTOS"
        Case "9"
            txtCentena = "NOVECIENTOS"
    End Select

    Select Case Decena
        Case "1"
            txtDecena = "DIEZ"
            Select Case Unidad
                Case "1"
                    txtDecena = "ONCE"
                Case "2"
                    txtDecena = "DOCE"
                Case "3"
                    txtDecena = "TRECE"
                Case "4"
                    txtDecena = "CATORCE"
                Case "5"
                    txtDecena = "QUINCE"
                Case "6"
                    txtDecena = "DIECISEIS"
                Case "7"
                    txtDecena = "DIECISIETE"
                Case "8"
                    txtDecena = "DIECIOCHO"
                Case "9"
                    txtDecena = "DIECINUEVE"
            End Select
        Case "2"
            txtDecena = "VEINTE"
            If Unidad <> "0" Then
                txtDecena = "VEINTI"
            End If
        Case "3"
            txtDecena = "TREINTA"
            If Unidad <> "0" Then
                txtDecena = "TREINTA Y "
            End If
        Case "4"
            txtDecena = "CUARENTA"
            If Unidad <> "0" Then
                txtDecena = "CUARENTA Y "
            End If
        Case "5"
            txtDecena = "CINCUENTA"
            If Unidad <> "0" Then
                txtDecena = "CINCUENTA Y "
            End If
        Case "6"
            txtDecena = "SESENTA"
            If Unidad <> "0" Then
                txtDecena = "SESENTA Y "
            End If
        Case "7"
            txtDecena = "SETENTA"
            If Unidad <> "0" Then
                txtDecena = "SETENTA Y "
            End If
        Case "8"
            txtDecena = "OCHENTA"
            If Unidad <> "0" Then
                txtDecena = "OCHENTA Y "
            End If
        Case "9"
            txtDecena = "NOVENTA"
            If Unidad <> "0" Then
                txtDecena = "NOVENTA Y "
            End If
    End Select

    If Decena <> "1" Then
        Select Case Unidad
            Case "1"
                If SW Then
                    txtUnidad = "UN"
                Else
                    txtUnidad = "UNO"
                End If
            Case "2"
                txtUnidad = "DOS"
            Case "3"
                txtUnidad = "TRES"
            Case "4"
                txtUnidad = "CUATRO"
            Case "5"
                txtUnidad = "CINCO"
            Case "6"
                txtUnidad = "SEIS"
            Case "7"
                txtUnidad = "SIETE"
            Case "8"
                txtUnidad = "OCHO"
            Case "9"
                txtUnidad = "NUEVE"
        End Select
    End If
    ConvierteCifra = txtCentena & " " & txtDecena & txtUnidad
End Function

'-------------------------------------------------

'Main Function
Function SpellNumber(ByVal MyNumber)
    Dim Dollars, Cents, Temp
    Dim DecimalPlace, Count
    ReDim Place(9) As String
    Place(2) = " Thousand "
    Place(3) = " Million "
    Place(4) = " Billion "
    Place(5) = " Trillion "
    ' String representation of amount.
    MyNumber = Trim(Str(MyNumber))
    ' Position of decimal place 0 if none.
    DecimalPlace = InStr(MyNumber, ".")
    ' Convert cents and set MyNumber to dollar amount.
    If DecimalPlace > 0 Then
        'Cents = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & _
                  "00", 2))
        Cents = Left(Mid(MyNumber, DecimalPlace + 1) & _
                  "00", 2)
        MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
    End If
    Count = 1
    Do While MyNumber <> ""
        Temp = GetHundreds(Right(MyNumber, 3))
        If Temp <> "" Then Dollars = Temp & Place(Count) & Dollars
        If Len(MyNumber) > 3 Then
            MyNumber = Left(MyNumber, Len(MyNumber) - 3)
        Else
            MyNumber = ""
        End If
        Count = Count + 1
    Loop
    Select Case Dollars
        Case ""
            Dollars = "No " '"No Dollars"
        Case "One"
            Dollars = "One " '"One Dollar"
         Case Else
            Dollars = Dollars  'Dollars & " Dollars"
    End Select
    Select Case Cents
        Case ""
            Cents = " And " & "00" '" And No Cents"
        Case "One"
            Cents = " And " & "01" 'One Cent"
              Case Else
            Cents = " And " & Cents '& " Cents"
    End Select
    SpellNumber = Dollars & Cents & "/100 U.S. Dollars" 'Dollars & Cents
End Function

' Converts a number from 100-999 into text
Function GetHundreds(ByVal MyNumber)
    Dim Result As String
    If Val(MyNumber) = 0 Then Exit Function
    MyNumber = Right("000" & MyNumber, 3)
    ' Convert the hundreds place.
    If Mid(MyNumber, 1, 1) <> "0" Then
        Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
    End If
    ' Convert the tens and ones place.
    If Mid(MyNumber, 2, 1) <> "0" Then
        Result = Result & GetTens(Mid(MyNumber, 2))
    Else
        Result = Result & GetDigit(Mid(MyNumber, 3))
    End If
    GetHundreds = Result
End Function

' Converts a number from 10 to 99 into text.
Function GetTens(TensText)
    Dim Result As String
    Result = ""           ' Null out the temporary function value.
    If Val(Left(TensText, 1)) = 1 Then   ' If value between 10-19...
        Select Case Val(TensText)
            Case 10: Result = "Ten"
            Case 11: Result = "Eleven"
            Case 12: Result = "Twelve"
            Case 13: Result = "Thirteen"
            Case 14: Result = "Fourteen"
            Case 15: Result = "Fifteen"
            Case 16: Result = "Sixteen"
            Case 17: Result = "Seventeen"
            Case 18: Result = "Eighteen"
            Case 19: Result = "Nineteen"
            Case Else
        End Select
    Else                                 ' If value between 20-99...
        Select Case Val(Left(TensText, 1))
            Case 2: Result = "Twenty "
            Case 3: Result = "Thirty "
            Case 4: Result = "Forty "
            Case 5: Result = "Fifty "
            Case 6: Result = "Sixty "
            Case 7: Result = "Seventy "
            Case 8: Result = "Eighty "
            Case 9: Result = "Ninety "
            Case Else
        End Select
        Result = Result & GetDigit _
            (Right(TensText, 1))  ' Retrieve ones place.
    End If
    GetTens = Result
End Function

' Converts a number from 1 to 9 into text.
Function GetDigit(Digit)
    Select Case Val(Digit)
        Case 1: GetDigit = "One"
        Case 2: GetDigit = "Two"
        Case 3: GetDigit = "Three"
        Case 4: GetDigit = "Four"
        Case 5: GetDigit = "Five"
        Case 6: GetDigit = "Six"
        Case 7: GetDigit = "Seven"
        Case 8: GetDigit = "Eight"
        Case 9: GetDigit = "Nine"
        Case Else: GetDigit = ""
    End Select
End Function

[/php]

Atte.

joshua

macro_num_a_texto_en_Ingles(1).xls

winnerclip · el 7 de septiembre

Joshua,

Agradecido por tu gran ayuda, funciona a la perfección, gracias por darnos la oportunidad de exponer nuestras dudas, preguntas y encontrar respuestas a ellas.

saludos.

Favor dar por solucionado y/o cerrado el Tema.

Winnerclip