Pasar datos de user form a celda en excel con formato porcentual

Estoy trabajando con un User Form que envía datos de facturación a una hoja de excel. Tengo un campo en el User Form que corresponde a descuento, necesito que este se copie en la hoja de excel con formato porcentual.

1 Respuesta

Respuesta
2

Sería un código de este tipo

Private Sub CommandButton1_Click()
a = TextBox1 / 100
porcentaje = Format(a, "0,0%")
Range("a1") = porcentaje
End Sub

Donde la variable porcentaje le asigna el formato descrito a la celda que necesites.

Gracias Juan Pedro:

Al hacerlo recibo el mensaje de 'Se a producido el error 13 en tiempo de ejecución: No coinciden los tipos

Supongo habrás creado el userform, ¿con el textbox correspondiente?, te anexo el excel con el ejemplo para ver si lo puedes adaptar.

https://mega.nz/#!4YxnATAB!3GAzMOciT_ry99RNeKfVa7yBtk8Oy72h_2c4IapV6rg

Estimado Juan Pedro:

Este es el User Form que estoy manejando

y este es el código actual de este UF, el rango en el que necesito que se copie el valor de descuento es "J" & FF + 16, claro, este valor deberá copiarse siempre y cuando se ingrese algún valor en el campo de descuento

Private Sub cmdAceptar_Click()
Dim Pos As Double
Dim Codigo As Single
Dim Producto As String
Dim Unidades As Single
Dim PrecioUni As Double     
Dim IVA As Variant
Dim B As Single
Dim UnidadesInventario As Variant
Pos = lstProductos.ListIndex
If Pos < 0 Then
    MsgBox "Por favor selecciona un producto de la lista.", 
      vbInformation, "Seleccionar Productos"
    Exit Sub
End If
Producto = lstProductos.List(Pos, 1)
If txtUnidades = "" Then
    MsgBox "Debes ingresar la cantidad de unidades a facturar del producto " 
     & Producto & ".", vbExclamation, "Ingresar Cantidad"
    Exit Sub
End If
If optPrecioVenta1.Value = False And optPrecioVenta2.Value = False And 
optPrecioVenta3.Value = False And optPrecioVenta4.Value = False Then
    MsgBox "Debes seleccionar alguno de los 4 precios de venta", 
vbExclamation, "Seleccionar Precio de Venta"
    Exit Sub
End If
If optPrecioVenta4.Value = True Then
    If txtPrecio4.Value = "" Then
        MsgBox "Debes ingresar el Precio de Venta 4", 
vbExclamation, "Ingresar precio de venta 4"
        Exit Sub
    Else
        If Not IsNumeric(txtPrecio4) Then
            txtPrecio4 = Empty
            MsgBox "Valor ingresado no es Numérico en Precio 4, 
intente nuevamente.", vbCritical, "Ingresar Precio de Venta 4"
            Exit Sub
        End If
    End If
End If
If Not IsNumeric(txtUnidades) Then
    txtUnidades = Empty
    MsgBox "Valor ingresado no es Numérico, intente nuevamente.", 
vbCritical, "Ingresar Cantidad Unidades"
    'EM: volver al control para que se ingrese este campo
    txtUnidades.SetFocus
    Exit Sub
End If
Unidades = txtUnidades.Value
UnidadesInventario = lstProductos.List(Pos, 3)
If Not IsNumeric(UnidadesInventario) Then
    MsgBox "No se han cargado las unidades disponibles al Inventario", 
vbCritical
    Exit Sub
End If
If Unidades > lstProductos.List(Pos, 3) Then
    MsgBox "La cantidad de unidades disponibles en inventario es 
menor a la solicitada para el producto " & Producto & ".", 
vbCritical, "Cantidad unidades"
    Exit Sub
End If
Application.ScreenUpdating = False
If optPrecioVenta1.Value = True Then PrecioUnitario = CDbl(txtPrecio1) 
If optPrecioVenta2.Value = True Then PrecioUnitario = CDbl(txtPrecio2)
If optPrecioVenta3.Value = True Then PrecioUnitario = CDbl(txtPrecio3)
If optPrecioVenta4.Value = True Then PrecioUnitario = CDbl(txtPrecio4)
Codigo = lstProductos.List(Pos, 0)
IVA = lstProductos.List(Pos, 4)
Hoja10.Visible = xlSheetVisible
Hoja10.Select
Range("B3").Select
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value <> "" Then
    Do While ActiveCell <> ""
        If ActiveCell.Value = Codigo Then
            FF = ActiveCell.Row
            Unidades = Unidades + Range("D" & FF).Value
            B = 1
            Exit Do
        End If
        ActiveCell.Offset(1, 0).Select
    Loop
    If B = 0 Then FF = ActiveCell.Row
Else
    FF = 4
End If
Range("B" & FF) = Codigo
Range("C" & FF) = Producto
Range("D" & FF) = Unidades
Range("E" & FF) = PrecioUnitario
Range("F" & FF) = Range("E" & FF).Value * Range("D" & FF)
Range("G" & FF) = IVA
Range("H" & FF) = Range("F" & FF).Value * Range("G" & FF)
Hoja10.Visible = xlSheetHidden
ListaProductos
ListaFactura
Hoja12.Select
txtUnidades = ""
txtPrecio1 = ""
txtPrecio2 = ""
txtPrecio3 = ""
txtPrecio4 = ""
txtDcto = "" 'LF AÑADIDO PARA PRUEBA DCTO
Application.ScreenUpdating = True
End Sub
Private Sub cmdCancelar_Click()
Application.ScreenUpdating = False
Hoja12.Select
End
End Sub
Private Sub cmdEliminarProducto_Click()
Dim PosE As Single
Dim CodigoE As Single
Dim ProudctoE As String
Application.ScreenUpdating = False
PosE = lstFactura.ListIndex
If PosE < 0 Then
    MsgBox "Por favor selecciona un producto a eliminar de la Factura.", 
vbInformation, "Seleccionar Productos"
    Exit Sub
End If
CodigoE = lstFactura.List(PosE, 0)
If CodigoE = 0 Then
    MsgBox "Por favor selecciona un producto a eliminar de la Factura.", 
vbInformation, "Seleccionar Productos"
    Exit Sub
End If
ProudctoE = lstFactura.List(PosE, 1)
Hoja10.Visible = xlSheetVisible
Hoja10.Select
Range("B3").Select
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value <> "" Then
    Do While ActiveCell.Value <> CodigoE
        ActiveCell.Offset(1, 0).Select
    Loop
    Selection.EntireRow.Delete
    MsgBox "Se eliminó de la factura el producto " & ProudctoE & ".",
 vbInformation, "Producto Eliminado"
Else
    MsgBox "El producto a eliminar no se encuentra en la factura", 
vbCritical, "Producto a Eliminar"
End If
Hoja10.Visible = xlSheetHidden
ListaProductos
ListaFactura
Hoja12.Select
Application.ScreenUpdating = True
End Sub
Private Sub cmdFacturar_Click()
      ' Dim Producto As Single    'EM: declaración duplicada
Dim Codigo As Single
Dim Producto As String
Dim Unidades As Single
Dim PrecioUnit As Double
Dim Subtotal As Double
Application.ScreenUpdating = False
If txtTotal.Value = 0 Then
    MsgBox "No hay productos para generar factura.", vbExclamation, 
"Generar Factura"
    Exit Sub
End If
Fact = MsgBox("Estás seguro de ingresar estos productos a la factura?", 
vbYesNo, "Generar Factura")
If Fact = vbYes Then
    Producto = lstFactura.ListCount - 1
    Hoja10.Visible = xlSheetVisible
    Hoja10.Select
    Range("B3").Select
    ActiveCell.Offset(1, 0).Select
    If ActiveCell.Value <> "" Then
        Range("B3").End(xlDown).Select
        FF = ActiveCell.Row
    Else
        FF = 4
    End If
    Range("B4" & ":G" & FF).Select
    Selection.Copy
    Hoja12.Select
    Range("D28").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Range("D27").End(xlDown).Select
    FF = ActiveCell.Row
    For I = 28 To FF
        Range("J" & I).FormulaLocal = "=H" & I & "*I" & I
        Range("K" & I).FormulaLocal = "=H" & I & "+J" & I
    Next
    Range("J" & FF + 15 & ":J" & FF + 19 & ",J" & FF + 15 & ":K" & FF + 
19 & ",J" & FF + 15 & ":K" & FF + 19 & ",J" & FF + 15 & ":K" & FF + 19)
.Select
    BordeDerecho
    BordeInferior
    BordeIzquierdo
    BordeSuperior ' LF: PINTA LAS LINEAS DE TOTALES
    BordeInternoHorizontal
    BordeInternoVertical
    Range("D28:K" & FF).Select
    BordeDerecho
    BordeInferior
    BordeIzquierdo
    BordeSuperior
    BordeInternoHorizontal
    BordeInternoVertical
    Range("J" & FF + 19 & ":K" & FF + 19).Select  
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
        .PatternTintAndShade = 0
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.149998474074526
        .Weight = xlThin
    End With
    BordeDerecho
    BordeInferior
    BordeIzquierdo
    BordeSuperior
    BordeInternoHorizontal
    BordeInternoVertical
    Range("D" & FF + 1 & ":K" & FF + 19).Select  
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.149998474074526
        .Weight = xlThin
    End With
    BordeDerecho
    BordeInferior
    BordeIzquierdo
    BordeSuperior  
    Range("J" & FF + 15) = "Subtotal:" '2 solo titulos
    Range("I" & FF + 16) = "Descuento:" '3
    Range("J" & FF + 17) = "Total IVA 5%:" '4
    Range("J" & FF + 18) = "Total IVA 16%:" '5
    Range("J" & FF + 19) = "Total Factura:" '6
    Range("J" & FF + 19 & ":K" & FF + 19).Select '6
    Selection.Font.Bold = True
    Range("K" & FF + 15).FormulaLocal = "=SUMA(H28:H" & FF & ")" 
    Range("K" & FF + 16).FormulaR1C1 = "=+R[-1]C*RC[-1]"
    Range("K" & FF + 17).FormulaR1C1 = "=SUMIFS(R28C[-1]:R[-4]C[-1],R28C
[-2]:R[-4]C[-2],5%)*(1-(R[-1]C[-1]))"
    Range("K" & FF + 18).FormulaR1C1 = "=SUMIFS(R28C[-1]:R[-4]C[-1],R28C
[-2]:R[-4]C[-2],16%)*(1-(R[-2]C[-1]))"
    Range("K" & FF + 19).FormulaLocal = "=K" & FF + 15 & "+K" & FF + 17 
& "+K" & FF + 18 & "-SUMA(K" & FF + 16 & ":K" & FF + 16 & ")"  
Else
    Exit Sub
End If
Hoja12.Select
End
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Hoja10.Visible = xlSheetVisible
Hoja10.Select
Range("B3").Select
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value <> "" Then
    Range("B3").End(xlDown).Select
    FF = ActiveCell.Row
    Rows("4:" & FF).Select
    Selection.Delete Shift:=xlUp
    Range("B3").Select
Else
    MsgBox "No hay productos en Factura", vbExclamation, 
"Borrar Productos"
    Hoja11.Visible = xlSheetHidden
    Hoja12.Select
    Exit Sub
End If
Hoja10.Visible = xlSheetHidden
ListaProductos
ListaFactura
Hoja12.Select
Application.ScreenUpdating = True
End Sub
Private Sub lstFactura_Click()
End Sub
Private Sub lstProductos_Click()
Dim Codigo As Single
Dim Precio1 As Double
Dim Precio2 As Double
Dim Precio3 As Double
Dim Item As Double
Application.ScreenUpdating = False
Item = lstProductos.ListIndex
If Item < 0 Then
    MsgBox "Por favor selecciona un producto de la lista", 
vbInformation
    Exit Sub
End If
optPrecioVenta1.Enabled = True
optPrecioVenta2.Enabled = True
optPrecioVenta3.Enabled = True
optPrecioVenta4.Enabled = True
optPrecioVenta1.Value = False
optPrecioVenta2.Value = False
optPrecioVenta3.Value = False
optPrecioVenta4.Value = False
txtPrecio4.Value = ""
txtPrecio4.Enabled = False
Item = lstProductos.ListIndex
Codigo = lstProductos.List(Item, 0)
If Codigo = 0 Then Exit Sub
Hoja11.Visible = xlSheetVisible
Hoja11.Select
Range("B3").Select
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value <> "" Then
    Do While ActiveCell <> ""
        If ActiveCell.Value = Codigo Then
            FF = ActiveCell.Row
            Exit Do
        End If
        ActiveCell.Offset(1, 0).Select
    Loop
End If
txtPrecio1 = Range("G" & FF).Value  
txtPrecio2 = Range("H" & FF).Value
txtPrecio3 = Range("I" & FF).Value
txtPrecio1 = Format(txtPrecio1, "$###,##0.00")  
txtPrecio2 = Format(txtPrecio2, "$###,##0.00")   
txtPrecio3 = Format(txtPrecio3, "$###,##0.00")  
txtPrecio4 = Format(txtPrecio4, "$###,##0.00")  
If txtPrecio1 = "" Then optPrecioVenta1.Enabled = False
If txtPrecio2 = "" Then optPrecioVenta2.Enabled = False
If txtPrecio3 = "" Then optPrecioVenta3.Enabled = False
Hoja12.Select
End Sub
Private Sub optPrecioVenta1_Click()
txtPrecio4.Enabled = False
txtPrecio4.Value = ""
End Sub
Private Sub optPrecioVenta2_Click()
txtPrecio4.Enabled = False
txtPrecio4.Value = ""
End Sub
Private Sub optPrecioVenta3_Click()
txtPrecio4.Enabled = False
txtPrecio4.Value = ""
End Sub
Private Sub optPrecioVenta4_Click()
txtPrecio4.Enabled = True
txtPrecio4 = Format(txtPrecio4, "$###,##0.00")  
Private Sub TextBox1_Change()
End Sub
Private Sub txtDcto_Change()    'Juan Pedro
a = txtDcto / 100
Porcentaje = Format(a, "0,0%")
Range("J" & FF + 16) = Porcentaje
End Sub
Private Sub txtPrecio1_Change()
End Sub
Private Sub txtPrecio2_Change()
End Sub
Private Sub txtPrecio3_Change()
End Sub
Private Sub txtPrecio4_AfterUpdate()
txtPrecio4 = Format(txtPrecio4, "$###,##0.00")  
End Sub
Private Sub txtUnidades_Change()
End Sub
Private Sub UserForm_Initialize()
Application.ScreenUpdating = False
Hoja12.Select
Range("D27").Select
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value <> "" Then
    Range("D27").End(xlDown).Select
    FF = ActiveCell.Row + 30
    Rows("28:" & FF).Select
    Selection.Delete Shift:=xlUp
    Range("D27").Select
End If
ListaProductos
ListaFactura
Hoja12.Select
txtPrecio4.Enabled = False
optPrecioVenta1.Enabled = False
optPrecioVenta2.Enabled = False
optPrecioVenta3.Enabled = False
optPrecioVenta4.Enabled = False
Application.ScreenUpdating = True
End Sub
Public Sub ListaProductos()
Application.ScreenUpdating = False
lstProductos.ColumnCount = 5
lstProductos.ColumnHeads = True
Hoja11.Visible = xlSheetVisible
Hoja11.Select
Range("B3").Select
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value <> "" Then
    While ActiveCell <> ""
        ActiveCell.Offset(1, 0).Select
    Wend
    FF = ActiveCell.Row - 1
Else
    FF = 4
End If
Range("B4:I" & FF).Select
Selection.ClearContents
Hoja6.Visible = xlSheetVisible
Hoja6.Select
Range("B3").Select
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value <> "" Then
    Range("B3").End(xlDown).Select
    FF = ActiveCell.Row
Else
    FF = 4
End If
Range("B4:I" & FF).Select
Selection.Copy
Hoja11.Select
Range("B4").Select
Selection.PasteSpecial Paste:=xlPasteValues
lstProductos.RowSource = "B4:F" & FF
Application.CutCopyMode = False
Hoja11.Visible = xlSheetHidden
Hoja12.Select
Application.ScreenUpdating = True
End Sub
Public Sub ListaFactura()
lstFactura.ColumnCount = 5
lstFactura.ColumnHeads = True
Application.ScreenUpdating = False
Hoja10.Visible = xlSheetVisible
Hoja10.Select
Range("B3").Select
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value <> "" Then
    While ActiveCell <> ""
        ActiveCell.Offset(1, 0).Select
    Wend
    FF = ActiveCell.Row - 1
    lstFactura.RowSource = "B4:F" & FF
End If
Range("F1").FormulaLocal = "=SUMA(F4:F" & FF & ")"
txtTotal = Range("F1").Value
txtTotal = Format(txtTotal, "$###,##0.00")  
Hoja10.Visible = xlSheetHidden
Hoja12.Select
Application.ScreenUpdating = True
End Sub
Public Sub BordeIzquierdo()
With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .ThemeColor = 1
    .TintAndShade = -0.349986266670736
    .Weight = xlThin
End With
End Sub
Public Sub BordeSuperior()
With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .ThemeColor = 1
    .TintAndShade = -0.349986266670736
    .Weight = xlThin
End With
End Sub
Public Sub BordeInferior()
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ThemeColor = 1
    .TintAndShade = -0.349986266670736
    .Weight = xlThin
End With
End Sub
Public Sub BordeDerecho()
With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .ThemeColor = 1
    .TintAndShade = -0.349986266670736
    .Weight = xlThin
End With
End Sub
Public Sub BordeInternoVertical()
With Selection.Borders(xlInsideVertical)
    .LineStyle = xlContinuous
    .ThemeColor = 1
    .TintAndShade = -0.349986266670736
    .Weight = xlThin
End With
End Sub
Public Sub BordeInternoHorizontal()
With Selection.Borders(xlInsideHorizontal)
    .LineStyle = xlContinuous
    .ThemeColor = 1
    .TintAndShade = -0.349986266670736
    .Weight = xlThin
End With
End Sub

Es un gran trabajo y yo no soy maestro en excel, solo un aprendiz un poco aventajado, por tanto mi ayuda no te va a servir, de todas formas para poder probar como hacerlo trabajar, comprenderás que no se puede crear todo ese código y userforms, lo conveniente sería que enviases el fichero, eliminando cualquier base de datos que tenga relación con tu trabajo e intentaría ponerlo en funcionamiento.

Si algún experto tiene la amabilidad de responderte y que no le haga falta el fichero, que comente las modificaciones necesarias.

Siento no poder hacer más.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas

Poner contraseña en visual basic thisworkbook

Tengo una función en ThisWorkbook que elimina el libro al llegar a una fecha de caducidad, ahora requiero colocar una contraseña para protección, la cual, al colocar una contraseña errónea, ejecute el borrado de la hoja
2 respuestas

¿Como cargar un valor recorriendos los controles (TextBox) de un formulario?

A tod@s! En un formulario tengo un ListBox, al ejecutar una accion llama a una macro, ejecutando un codigo. Este codigo esta en un modulo y consiste en recorrer las columnas de la fila elegida en el Listbox y añadiendolo a los TextBox de un...
1 respuesta

Cómo borrar un texto predeterminado en un Textbox al hacer click

Tengo un Textbox en un formulario con un texto predeterminado, Segundo Nombre, pero quisiera que al hacer click en este desaparezca automáticamente para empezar a completar la información deseada. La información del Segundo Nombre se graba en la...
3 respuestas

Macro exportar excel a sentencia SQL

Desde un archivo excel necesito crear un archivo *.txt para incorporar a mi base sql. Te adjunto lo que necesitaría en una imagen. (En este caso son dos filas pero podrían ser más). Se que traspasa lo que es una duda, pero es que los conocimientos en...
2 respuestas

Calcular Mantenimiento preventivo de automóvil

Antes que nada hola a todos!. Bueno hoy tengo un pequeño problema a resolver con un programa que se me solicito desarrollar en php. Por ejemplo a cada automóvil se le debe realizar mantenimiento a los 10, 000 Km. Y mandar una notificación o alerta de...
3 respuestas

Resaltar celda de hoja1 si la celda de la hoja2 es igual

Me podrian ayudar necesito una macro para resaltar las celdas de la hoja1 de color amarillo conforme se van agregando en la hoja 2. Hoja1 hoja2 NOMBRE NOMBRE LUIS ERNESTO JUAN FABIO PEDRO LUIS ISAIAS PEDRO ESTEBAN PAOLO MAURO
3 respuestas

Conversión de números a letras en LPP

Necesito desarrollar un algoritmo con la función MIENTRAS que permita la entrada de un numero de un dígito y escriba su valor en letras, el algoritmo se debe repetir hasta que se ingrese una letra. Ejemplo: si el usuario digita el número 4, el...
2 respuestas

Excel - calcular la diferencia en meses entre dos fechas diferenciado en que años

2 fechas en dos celdas con 4 años de diferencia (o 5 o los que sean), como calcular la cantidad de meses por año
2 respuestas

¿Se pueden automatizar procesos en excel?

La presente es para solicitar amablemente su ayuda, como pueden observar en el presente archivo de excel denominado relación de consumos de QBANO, tengo 3 hojas con los siguientes nombres: HODECOL, MULTIVACIONES Y SERVINCLUIDOS, necesito una macro o...
1 respuesta

Como puedo hacer para Exportar un informe de Access a PDF añadiendo fecha y la hora actual del Pc

Tengo este código, pero no tiene la fecha y la hora ¿Cómo hago? Sería Algo así cuando guarda: Test 2023-07-06 15:21.PDF Private Sub Comando1172_Click() Dim strUserName As String, strPath As String strPath = "C:\Users\usuario\Documents\test.pdf"...
2 respuestas