Fechas y numeros que se escriban

Cristhian

New Member
Joined
Feb 20, 2021
Messages
3
Office Version
  1. 2019
Platform
  1. Windows
Hola amigos

necesito una macro, no función, macro que cuando desde mi formulario escriba una fecha y un monto cualquiera, al pasarla al excel planilla, en la celda continua se escriba, es decir, si yo escribo la fecha 12/03/1975, en la celda de al lado se escriba automáticamente, 12 de marzo de 1975, y con respecto a las cifras ejemplo 500.000, que se escriba en la celda de al lado Quinientos mil.

Para la fecha
1613838781204.png


para las cifras
1613838826905.png

la macro que tengo pero funcion y necesito una macro:

VBA Code:
Function NumLetrasPais(Valor As Currency, pais As String) As String

    Dim lyCantidad As Currency, lyCentavos As Long, lnDigito As Byte, lnPrimerDigito As Byte, lnSegundoDigito As Byte, lnTercerDigito As Byte, lcBloque As String, lnNumeroBloques As Byte, lnBloqueCero
    Dim laUnidades As Variant, laDecenas As Variant, laCentenas As Variant, I As Variant 'Si esta como Option Explicit
    Dim ValorEntero As Long
    Dim cant_letras As String

    pais = UCase(pais)

    Valor = Round(Valor, 2)
    lyCantidad = Int(Valor)
    ValorEntero = lyCantidad
     
    cant_letras = ValorALetras(ValorEntero)
   
    Select Case pais
    Case "CL"
        NumLetrasPais = cant_letras & " "
       
        End Select
   
End Function

Function ValorALetras(Valor As Long) As String

    Dim lyCantidad As Currency, lnDigito As Byte, lnPrimerDigito As Byte, lnSegundoDigito As Byte, lnTercerDigito As Byte, lcBloque As String, lnNumeroBloques As Byte, lnBloqueCero
    Dim laUnidades As Variant, laDecenas As Variant, laCentenas As Variant, I As Variant 'Si esta como Option Explicit
    Dim ValorEntero As Long

    Valor = Round(Valor, 2)
    lyCantidad = Int(Valor)
    ValorEntero = lyCantidad
    laUnidades = Array("UN", "DOS", "TRES", "CUATRO", "CINCO", "SEIS", "SIETE", "OCHO", "NUEVE", "DIEZ", "ONCE", "DOCE", "TRECE", "CATORCE", "QUINCE", "DIECISEIS", "DIECISIETE", "DIECIOCHO", "DIECINUEVE", "VEINTE", "VEINTIUN", "VEINTIDOS", "VEINTITRES", "VEINTICUATRO", "VEINTICINCO", "VEINTISEIS", "VEINTISIETE", "VEINTIOCHO", "VEINTINUEVE")
    laDecenas = Array("DIEZ", "VEINTE", "TREINTA", "CUARENTA", "CINCUENTA", "SESENTA", "SETENTA", "OCHENTA", "NOVENTA")
    laCentenas = Array("CIENTO", "DOSCIENTOS", "TRESCIENTOS", "CUATROCIENTOS", "QUINIENTOS", "SEISCIENTOS", "SETECIENTOS", "OCHOCIENTOS", "NOVECIENTOS")
    lnNumeroBloques = 1
   
    Do
        lnPrimerDigito = 0
        lnSegundoDigito = 0
        lnTercerDigito = 0
        lcBloque = ""
        lnBloqueCero = 0
        For I = 1 To 3
            lnDigito = lyCantidad Mod 10
            If lnDigito <> 0 Then
                Select Case I
                Case 1
                    lcBloque = " " & laUnidades(lnDigito - 1)
                    lnPrimerDigito = lnDigito
                Case 2
                    If lnDigito <= 2 Then
                        lcBloque = " " & laUnidades((lnDigito * 10) + lnPrimerDigito - 1)
                    Else
                    lcBloque = " " & laDecenas(lnDigito - 1) & IIf(lnPrimerDigito <> 0, " Y", Null) & lcBloque
                    End If
                    lnSegundoDigito = lnDigito
                Case 3
                    lcBloque = " " & IIf(lnDigito = 1 And lnPrimerDigito = 0 And lnSegundoDigito = 0, "CIEN", laCentenas(lnDigito - 1)) & lcBloque
                    lnTercerDigito = lnDigito
                End Select
            Else
                lnBloqueCero = lnBloqueCero + 1
            End If
            lyCantidad = Int(lyCantidad / 10)
            If lyCantidad = 0 Then
                Exit For
            End If
        Next I
        Select Case lnNumeroBloques
            Case 1
                ValorALetras = lcBloque
            Case 2
                ValorALetras = lcBloque & IIf(lnBloqueCero = 3, Null, " MIL") & ValorALetras
            Case 3
                ValorALetras = lcBloque & IIf(lnPrimerDigito = 1 And lnSegundoDigito = 0 And lnTercerDigito = 0, " MILLON", " MILLONES") & ValorALetras
        End Select
        lnNumeroBloques = lnNumeroBloques + 1
    Loop Until lyCantidad = 0
   
End Function

Dim Letras As Variant, N As Currency, E As Long, L As Variant, M As Long, Z As Long
Dim U As Variant, D As Variant, D1 As Variant, D2 As Variant, C As Variant
Function MACROLETRAS(Número As Double) As Variant: On Error Resume Next

MACROLETRAS = ""
N = Número

U = Array("", "UNO", "DOS", "TRES", "CUA-TRO", "CIN-CO", "SEIS", "SIE-TE", "OCHO", "NUE-VE", "DIEZ")
D = Array("", "DIEZ", "VEIN-TE", "TREIN-TA", "CUA-REN-TA", "CIN-CUEN-TA", "SE-SEN-TA", "SE-TEN-TA", "OCHEN-TA", "NO-VEN-TA", "CIEN")
D1 = Array("", "ON-CE", "DO-CE", "TRE-CE", "CA-TOR-CE", "QUIN-CE", "DIE-CI-SEIS", "DIE-CI-SIE-TE", "DIE-CIO-CHO", "DIE-CI-NUE-VE", "VEIN-TE")
D2 = Array("", "VEIN-TIUN", "VEIN-TI-DOS", "VEIN-TI-TRES", "VEIN-TI-CUATRO", "VEIN-TIC-INCO", "VEIN-TIS-EIS", "VEIN-TI-SIE-TE", "VEIN-TI-OCHO", "VEIN-TI-NUE-VE", "TREIN-TA")
C = Array("", "CIEN-TO", "DOS-CIEN-TOS", "TRES-CIEN-TOS", "CUATRO-CIEN-TOS", "QUI-NI-EN-TOS", "SEIS-CIEN-TOS", "SE-TE-CIEN-TOS", "OCHO-CIEN-TOS", "NO-VE-CIEN-TOS", "MIL")

If N = 0 Then Exit Function
E = Int(N)
M = (N - E) * 100
Letras = ""
Z = 0
'----------------------MILLONES
U(1) = "UN"
If E > 999999 Then
   Z = Int(E / 1000000)
   HASTA_1000 Z, False
   If Z = 1 Then
      Letras = L & " MILLON "
   Else
      Letras = L & " MILLONES "
   End If
   E = E - (Z * 1000000)
End If

'------------------------MILES
U(1) = ""
If E > 999 Then
   Z = Int(E / 1000)
   HASTA_1000 Z, True
   Letras = Letras & L & " MIL "
   E = E - (Z * 1000)
End If

'------------------------CIENTOS
If E > 0 Then
   U(1) = "UN"
   HASTA_1000 E, False
   Letras = Letras & L
End If

'------------------------CENTIMOS
If M > 0 Then
   HASTA_1000 M, False
   If Int(N) > 0 Then
      Letras = Letras & " CON" & L & " CENTIMOS"
   Else
      Letras = L & " CENTIMOS"
   End If
End If

Letras = Replace(Letras, "  ", " ")
Letras = Replace(Letras, "-", "")
If Right(Letras, 2) = "UN" Then Letras = Letras + "O"
MACROLETRAS = Trim(Letras)
End Function

Private Sub HASTA_1000(ByVal CIFRA As Long, MILES As Boolean)
L = ""
If CIFRA = 0 Then Exit Sub

'-----------------------------------------------------
If CIFRA > 100 Then 'CENTENAS
   X = Int(CIFRA / 100)
   L = C((CIFRA - CIFRA Mod 100) / 100)
   CIFRA = CIFRA - (X * 100)
End If

If CIFRA < 11 Then 'UNIDADES
   L = L & " " & U(CIFRA)
   Exit Sub
End If

If CIFRA < 21 Then 'DIECES
   L = L & " " & D1(CIFRA - 10)
   Exit Sub
End If

If CIFRA < 31 Then 'VEINTES
   L = L & " " & D2(CIFRA - 20)
   Exit Sub
End If

If CIFRA < 101 Then 'RESTO DECENAS
   X = CIFRA Mod 10
   L = L & " " & D((CIFRA - X) / 10)
   If X > 0 Then L = L & " Y " & U(X)
   Exit Sub
End If

End Sub


de antemano muchas gracias
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.

mrshl9898

Well-known Member
Joined
Feb 6, 2012
Messages
1,777
Something like this should work. Depends how you enter data.

If you use ENTER:

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    
If Not Intersect(Target, Range("A1:ZZ100000")) Is Nothing Then

    If IsDate(Cells(ActiveCell.Row - 1, ActiveCell.Column)) Then
    Cells(ActiveCell.Row - 1, ActiveCell.Column + 1) = Format(Cells(ActiveCell.Row, ActiveCell.Column), "Mmmm dd,yyyy")
    ElseIf IsNumeric(Cells(ActiveCell.Row - 1, ActiveCell.Column)) Then
    Cells(ActiveCell.Row - 1, ActiveCell.Column + 1) = SpellNumber(Cells(ActiveCell.Row - 1, ActiveCell.Column))
    End If

End If

End Sub



Function SpellNumber(ByVal numIn)
    Dim LSide, RSide, Temp, DecPlace, Count, oNum
    oNum = numIn
    ReDim Place(9) As String
    Place(2) = " Thousand "
    Place(3) = " Million "
    Place(4) = " Billion "
    Place(5) = " Trillion "
    numIn = Trim(Str(numIn)) 'String representation of amount
    ' Edit 2.(0)/Internationalisation
    ' Don't change point sign here as the above assignment preserves the point!
    DecPlace = InStr(numIn, ".") 'Pos of dec place 0 if none
    If DecPlace > 0 Then 'Convert Right & set numIn
        RSide = GetTens(Left(Mid(numIn, DecPlace + 1) & "00", 2))
        numIn = Trim(Left(numIn, DecPlace - 1))
    End If
    RSide = numIn
    Count = 1
    Do While numIn <> ""
        Temp = GetHundreds(Right(numIn, 3))
        If Temp <> "" Then LSide = Temp & Place(Count) & LSide
        If Len(numIn) > 3 Then
            numIn = Left(numIn, Len(numIn) - 3)
        Else
            numIn = ""
        End If
        Count = Count + 1
    Loop

    SpellNumber = LSide
    If InStr(oNum, Application.DecimalSeparator) > 0 Then    ' << Edit 2.(1)
        SpellNumber = SpellNumber & " point " & fractionWords(oNum)
    End If

End Function

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

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

Function GetDigit(Digit) 'Converts a number from 1 to 9 into text
    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

Function fractionWords(n) As String
    Dim fraction As String, x As Long
    fraction = Split(n, Application.DecimalSeparator)(1)   ' << Edit 2.(2)
    For x = 1 To Len(fraction)
        If fractionWords <> "" Then fractionWords = fractionWords & " "
        fractionWords = fractionWords & GetDigit(Mid(fraction, x, 1))
    Next x
End Function
 

Cristhian

New Member
Joined
Feb 20, 2021
Messages
3
Office Version
  1. 2019
Platform
  1. Windows
Something like this should work. Depends how you enter data.

If you use ENTER:

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
   
If Not Intersect(Target, Range("A1:ZZ100000")) Is Nothing Then

    If IsDate(Cells(ActiveCell.Row - 1, ActiveCell.Column)) Then
    Cells(ActiveCell.Row - 1, ActiveCell.Column + 1) = Format(Cells(ActiveCell.Row, ActiveCell.Column), "Mmmm dd,yyyy")
    ElseIf IsNumeric(Cells(ActiveCell.Row - 1, ActiveCell.Column)) Then
    Cells(ActiveCell.Row - 1, ActiveCell.Column + 1) = SpellNumber(Cells(ActiveCell.Row - 1, ActiveCell.Column))
    End If

End If

End Sub



Function SpellNumber(ByVal numIn)
    Dim LSide, RSide, Temp, DecPlace, Count, oNum
    oNum = numIn
    ReDim Place(9) As String
    Place(2) = " Thousand "
    Place(3) = " Million "
    Place(4) = " Billion "
    Place(5) = " Trillion "
    numIn = Trim(Str(numIn)) 'String representation of amount
    ' Edit 2.(0)/Internationalisation
    ' Don't change point sign here as the above assignment preserves the point!
    DecPlace = InStr(numIn, ".") 'Pos of dec place 0 if none
    If DecPlace > 0 Then 'Convert Right & set numIn
        RSide = GetTens(Left(Mid(numIn, DecPlace + 1) & "00", 2))
        numIn = Trim(Left(numIn, DecPlace - 1))
    End If
    RSide = numIn
    Count = 1
    Do While numIn <> ""
        Temp = GetHundreds(Right(numIn, 3))
        If Temp <> "" Then LSide = Temp & Place(Count) & LSide
        If Len(numIn) > 3 Then
            numIn = Left(numIn, Len(numIn) - 3)
        Else
            numIn = ""
        End If
        Count = Count + 1
    Loop

    SpellNumber = LSide
    If InStr(oNum, Application.DecimalSeparator) > 0 Then    ' << Edit 2.(1)
        SpellNumber = SpellNumber & " point " & fractionWords(oNum)
    End If

End Function

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

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

Function GetDigit(Digit) 'Converts a number from 1 to 9 into text
    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

Function fractionWords(n) As String
    Dim fraction As String, x As Long
    fraction = Split(n, Application.DecimalSeparator)(1)   ' << Edit 2.(2)
    For x = 1 To Len(fraction)
        If fractionWords <> "" Then fractionWords = fractionWords & " "
        fractionWords = fractionWords & GetDigit(Mid(fraction, x, 1))
    Next x
End Function

mrshl9898

Thanks for answering, I get the following

1613942170990.png


Thank you
 

Cristhian

New Member
Joined
Feb 20, 2021
Messages
3
Office Version
  1. 2019
Platform
  1. Windows
by form

1613948130027.png


Sub Guardar()
Dim RCodigos As Range
Dim NuevaFila As Range
Dim Uf As Long
Dim UltimaFila, FilaNumero, UltimoNumero As Integer 'Contador numerico

'Contador numerico
UltimaFila = Sheets("Base Datos").Range("B" & Rows.Count).End(xlUp).Row
FilaNumero = Sheets("Base Datos").Range("A" & Rows.Count).End(xlUp).Row
If (UltimoNumero > FilaNumero) Then
If (FilaNumero = 1) Then
UltimoNumero = 1
Else
UltimoNumero = Sheets("Base Datos").Range("A" & FilaNumero).Value + 1
End If
Sheets("Base Datos").Range("A" & FilaNumero + 1).Value = UltimoNumero

End If

'Si falta rellenar unos de estos datos no se guardara
If FrmADIP.TextBox1.Text = "" Or FrmADIP.TextBox2.Text = "" Or FrmADIP.ComboBox1 = "" Or FrmADIP.TextBox3.Text = "" Or FrmADIP.TextBox4.Text = "" Or FrmADIP.TextBox5.Text = "" Or FrmADIP.TextBox6.Text = "" Or _
FrmADIP.TextBox7 = "" Or FrmADIP.TextBox8 = "" Or FrmADIP.ComboBox2 = "" Or FrmADIP.ComboBox3 = "" Or FrmADIP.ComboBox4 = "" Or FrmADIP.TextBox9.Text = "" Or FrmADIP.ComboBox5 = "" Or FrmADIP.ComboBox6 = "" Or FrmADIP.ComboBox7 = "" Then

MsgBox "Faltan rellenar campos."


Else

Set RCodigos = Worksheets("Base Datos").ListObjects("BD").ListColumns(2).Range

Set Codigo = RCodigos.Find(What:=FrmADIP.TextBox2.Text, _
After:=Worksheets("Base Datos").Range("B6"), LookAt:=xlWhole)


' Traspasar los datos a las hojas Base
If Codigo Is Nothing Then
Set NuevaFila = Worksheets("Base Datos").ListObjects("BD").ListRows.Add.Range
If Sheets("Base Datos").Cells(FilaNumero, 1) = "N°" Then
Sheets("Base Datos").Cells(1 + FilaNumero, 1) = 1
Else
Sheets("Base Datos").Cells(1 + FilaNumero, 1) = Sheets("Base Datos").Cells(FilaNumero, 1) + 1
End If
NuevaFila.Cells(22).Value = FrmADIP.TextBox1.Text 'F Ingreso
NuevaFila.Cells(2).Value = FrmADIP.TextBox2.Text 'codigo
NuevaFila.Cells(38).Value = FrmADIP.ComboBox1.Text 'Area Negocio
NuevaFila.Cells(37).Value = FrmADIP.TextBox3.Text 'Cliente
NuevaFila.Cells(4).Value = FrmADIP.TextBox4.Text 'Ap Paterno
NuevaFila.Cells(5).Value = FrmADIP.TextBox5.Text 'Ap Materno
NuevaFila.Cells(6).Value = FrmADIP.TextBox6.Text 'nombre
NuevaFila.Cells(7).Value = FrmADIP.TextBox7.Text 'RUT
NuevaFila.Cells(14).Value = FrmADIP.TextBox8.Text & " " & "N°" & FrmADIP.TextBox9.Text 'Dirección y N°Dirección
NuevaFila.Cells(17).Value = FrmADIP.ComboBox2.Text 'Región
NuevaFila.Cells(16).Value = FrmADIP.ComboBox3.Text 'Ciudad
NuevaFila.Cells(15).Value = FrmADIP.ComboBox4.Text 'Comuna
NuevaFila.Cells(8).Value = FrmADIP.TextBox10.Text 'Fecha nacimiento
NuevaFila.Cells(10).Value = FrmADIP.TextBox11.Text 'Edad
NuevaFila.Cells(3).Value = FrmADIP.ComboBox5.Text 'Vigencia
NuevaFila.Cells(13).Value = FrmADIP.ComboBox6.Text 'Nacionalidad
NuevaFila.Cells(12).Value = FrmADIP.ComboBox7.Text 'Estado civil
NuevaFila.Cells(11).Value = FrmADIP.ComboBox8.Text 'Sexo
NuevaFila.Cells(19).Value = FrmADIP.TextBox12.Text 'Telefono 1
NuevaFila.Cells(20).Value = FrmADIP.TextBox13.Text 'Telefono 2
NuevaFila.Cells(21).Value = FrmADIP.TextBox15.Text 'Email
NuevaFila.Cells(18).Value = FrmADIP.ComboBox9.Text 'Cargo
NuevaFila.Cells(39).Value = FrmADIP.ComboBox10.Text 'Obra
NuevaFila.Cells(40).Value = FrmADIP.ComboBox11.Text 'C.Costo
NuevaFila.Cells(26).Value = FrmADIP.TextBox16.Text 'Sldo. Base 500000
NuevaFila.Cells(28).Value = FrmADIP.TextBox17.Text 'Colacion 40000
NuevaFila.Cells(30).Value = FrmADIP.TextBox18.Text 'Movilizacion 40000


End With

Else
MsgBox "El Código ya existe."
End If

End If

Call Mimodulo.Limpiar

End Sub

When saving they go to the excel sheet

Thank you
 

mrshl9898

Well-known Member
Joined
Feb 6, 2012
Messages
1,777
Ok, thanks.

Perhaps:

VBA Code:
Sub Guardar()
Dim RCodigos As Range
Dim NuevaFila As Range
Dim Uf As Long
Dim UltimaFila, FilaNumero, UltimoNumero As Integer 'Contador numerico

'Contador numerico
UltimaFila = Sheets("Base Datos").Range("B" & Rows.Count).End(xlUp).Row
FilaNumero = Sheets("Base Datos").Range("A" & Rows.Count).End(xlUp).Row
If (UltimoNumero > FilaNumero) Then
If (FilaNumero = 1) Then
UltimoNumero = 1
Else
UltimoNumero = Sheets("Base Datos").Range("A" & FilaNumero).Value + 1
End If
Sheets("Base Datos").Range("A" & FilaNumero + 1).Value = UltimoNumero

End If

'Si falta rellenar unos de estos datos no se guardara
If FrmADIP.TextBox1.Text = "" Or FrmADIP.TextBox2.Text = "" Or FrmADIP.ComboBox1 = "" Or FrmADIP.TextBox3.Text = "" Or FrmADIP.TextBox4.Text = "" Or FrmADIP.TextBox5.Text = "" Or FrmADIP.TextBox6.Text = "" Or _
FrmADIP.TextBox7 = "" Or FrmADIP.TextBox8 = "" Or FrmADIP.ComboBox2 = "" Or FrmADIP.ComboBox3 = "" Or FrmADIP.ComboBox4 = "" Or FrmADIP.TextBox9.Text = "" Or FrmADIP.ComboBox5 = "" Or FrmADIP.ComboBox6 = "" Or FrmADIP.ComboBox7 = "" Then

MsgBox "Faltan rellenar campos."


Else

Set RCodigos = Worksheets("Base Datos").ListObjects("BD").ListColumns(2).Range

Set Codigo = RCodigos.Find(What:=FrmADIP.TextBox2.Text, _
After:=Worksheets("Base Datos").Range("B6"), LookAt:=xlWhole)


' Traspasar los datos a las hojas Base
If Codigo Is Nothing Then
Set NuevaFila = Worksheets("Base Datos").ListObjects("BD").ListRows.Add.Range
If Sheets("Base Datos").Cells(FilaNumero, 1) = "N°" Then
Sheets("Base Datos").Cells(1 + FilaNumero, 1) = 1
Else
Sheets("Base Datos").Cells(1 + FilaNumero, 1) = Sheets("Base Datos").Cells(FilaNumero, 1) + 1
End If
NuevaFila.Cells(22).Value = FrmADIP.TextBox1.Text 'F Ingreso
NuevaFila.Cells(2).Value = FrmADIP.TextBox2.Text 'codigo
NuevaFila.Cells(38).Value = FrmADIP.ComboBox1.Text 'Area Negocio
NuevaFila.Cells(37).Value = FrmADIP.TextBox3.Text 'Cliente
NuevaFila.Cells(4).Value = FrmADIP.TextBox4.Text 'Ap Paterno
NuevaFila.Cells(5).Value = FrmADIP.TextBox5.Text 'Ap Materno
NuevaFila.Cells(6).Value = FrmADIP.TextBox6.Text 'nombre
NuevaFila.Cells(7).Value = FrmADIP.TextBox7.Text 'RUT
NuevaFila.Cells(14).Value = FrmADIP.TextBox8.Text & " " & "N°" & FrmADIP.TextBox9.Text 'Dirección y N°Dirección
NuevaFila.Cells(17).Value = FrmADIP.ComboBox2.Text 'Región
NuevaFila.Cells(16).Value = FrmADIP.ComboBox3.Text 'Ciudad
NuevaFila.Cells(15).Value = FrmADIP.ComboBox4.Text 'Comuna
NuevaFila.Cells(8).Value = FrmADIP.TextBox10.Text 'Fecha nacimiento
NuevaFila.Cells(9).Value = Format(FrmADIP.TextBox10.Text, "Mmmm dd,yyyy")
NuevaFila.Cells(10).Value = FrmADIP.TextBox11.Text 'Edad
NuevaFila.Cells(3).Value = FrmADIP.ComboBox5.Text 'Vigencia
NuevaFila.Cells(13).Value = FrmADIP.ComboBox6.Text 'Nacionalidad
NuevaFila.Cells(12).Value = FrmADIP.ComboBox7.Text 'Estado civil
NuevaFila.Cells(11).Value = FrmADIP.ComboBox8.Text 'Sexo
NuevaFila.Cells(19).Value = FrmADIP.TextBox12.Text 'Telefono 1
NuevaFila.Cells(20).Value = FrmADIP.TextBox13.Text 'Telefono 2
NuevaFila.Cells(21).Value = FrmADIP.TextBox15.Text 'Email
NuevaFila.Cells(18).Value = FrmADIP.ComboBox9.Text 'Cargo
NuevaFila.Cells(39).Value = FrmADIP.ComboBox10.Text 'Obra
NuevaFila.Cells(40).Value = FrmADIP.ComboBox11.Text 'C.Costo
NuevaFila.Cells(26).Value = FrmADIP.TextBox16.Text 'Sldo. Base 500000
NuevaFila.Cells(27).Value = SpellNumber(FrmADIP.TextBox16.Text)
NuevaFila.Cells(28).Value = FrmADIP.TextBox17.Text 'Colacion 40000
NuevaFila.Cells(29).Value = SpellNumber(FrmADIP.TextBox17.Text)
NuevaFila.Cells(30).Value = FrmADIP.TextBox18.Text 'Movilizacion 40000
NuevaFila.Cells(31).Value = SpellNumber(FrmADIP.TextBox18.Text)

End With

Else
MsgBox "El Código ya existe."
End If

End If

Call Mimodulo.Limpiar

End Sub


Function SpellNumber(ByVal numIn)
    Dim LSide, RSide, Temp, DecPlace, Count, oNum
    oNum = numIn
    ReDim Place(9) As String
    Place(2) = " Thousand "
    Place(3) = " Million "
    Place(4) = " Billion "
    Place(5) = " Trillion "
    numIn = Trim(Str(numIn)) 'String representation of amount
    ' Edit 2.(0)/Internationalisation
    ' Don't change point sign here as the above assignment preserves the point!
    DecPlace = InStr(numIn, ".") 'Pos of dec place 0 if none
    If DecPlace > 0 Then 'Convert Right & set numIn
        RSide = GetTens(Left(Mid(numIn, DecPlace + 1) & "00", 2))
        numIn = Trim(Left(numIn, DecPlace - 1))
    End If
    RSide = numIn
    Count = 1
    Do While numIn <> ""
        Temp = GetHundreds(Right(numIn, 3))
        If Temp <> "" Then LSide = Temp & Place(Count) & LSide
        If Len(numIn) > 3 Then
            numIn = Left(numIn, Len(numIn) - 3)
        Else
            numIn = ""
        End If
        Count = Count + 1
    Loop

    SpellNumber = LSide
    If InStr(oNum, Application.DecimalSeparator) > 0 Then    ' << Edit 2.(1)
        SpellNumber = SpellNumber & " point " & fractionWords(oNum)
    End If

End Function

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

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

Function GetDigit(Digit) 'Converts a number from 1 to 9 into text
    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

Function fractionWords(n) As String
    Dim fraction As String, x As Long
    fraction = Split(n, Application.DecimalSeparator)(1)   ' << Edit 2.(2)
    For x = 1 To Len(fraction)
        If fractionWords <> "" Then fractionWords = fractionWords & " "
        fractionWords = fractionWords & GetDigit(Mid(fraction, x, 1))
    Next x
End Function
 

Watch MrExcel Video

Forum statistics

Threads
1,129,714
Messages
5,637,940
Members
416,993
Latest member
ant8989

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top