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.

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

¿Cómo resolver num a letras en excel?

En un libro excel habilitado para macros al convertir números a letras, en lugar de aparecer el resultado esperado aparece el mensaje # ¿NOMBRE?.
1 respuesta

´No sé que fórmulas usar para resolverme el problema

La imagen no me la sube y tampoco veo como se sube un fichero, os intentaré explicar lo mejor que pueda mi problema. En una hoja Excel tengo hallados los pagos por formas de pago: SUMAR.SI(D1:D16;"Efectivo";B1:B16), y...
1 respuesta

¿Cómo usar un excel con macros desde varios ordenadores?

A tod@s! Tengo una aplicación en excel para introducir datos y visualizarlos con diferentes formularios creados. Lo que quiero hacer es: 1 Que ese libro este alojado en un sitio común y que lo puedan abrir desde varios ordenadores. 2º Que se pueda...
3 respuestas

Error en macro al ejecutar el botón aceptar

Necesitaría la colaboración para resolver el error que sucede al ejecutar el botón aceptar Set mifila = Hoja2.ListObjects(1).ListRows.Add Lo que yo agregue solamente a la base fue una columna al inicio ("A") anteriormente se llamaba Tabla6 y yo ahora...
1 respuesta

Detectar cambios en tabla dinámica

Tengo una hoja donde se van actualizando datos mediante una tabla dinámica. ¿Cómo detecto cuando se producen cambios (sólo en la parte de la tabla dinámica) para ejecutar otra macro en la misma hoja?
1 respuesta

Macro con combinación de teclas

Acudo aquí buscando ayuda, ¿Cómo crear una macro que genere una combinación de teclas? NO se trata de asignar una macro a una combinación de teclas, es todo lo contrario. El problema radica en que tengo una macro que rellena ciertas celdas con...
1 respuesta

Pasar datos de listbox a hoja con decimales

Como están estimados maestros y maestras, una vez mas solicitando vuestra experta ayuda. Tengo un formulario que busca datos entre 2 fechas desde 2 textbox, carga en listbox lo filtrado, en la columna 2 del listbox carga valores con formato de 2...
1 respuesta

Una macro que de aviso sobre vencimiento de una cedula de identidad

Tengo una hoja de calculo de 6 columnas en donde la columna A es fecha de vencimiento, las columnas B, C, y D son apellidos paterno, Materno u nombres, la columna E es el numero de cedula de identidad Con Formato ##.###.###-# la columna F es lo...
1 respuesta

Error decimales en hoja de excel

Tengo un albarán de varios productos que no vienen desglosado el iva En una hoja Excel introduzco el precio, con la formula sumar el precio lo desgloso en base imponible y el iva paracque me dé el precio del producto pero cuando sumo el total de...
4 respuestas

Filtrar información y luego pasar a otro libro

Tengo una macro que copia y pega del libro llamado Origen y Hoja1, dónde este está cerrado, al libro Destino y Hoja 2 de la siguiente manera: Sub importar() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual...
1 respuesta