Jump to content
  • Debido a la crisis sanitaria, hasta el día 31 de marzo, el registro al foro de Ayuda Excel será totalmente gratuito para facilitar el teletrabajo. Todos los registros que se produzcan entre estas fechas tendrán acceso gratuito ilimitado a la comunidad hasta el 30 de abril.

    Regístrate

    Si te surge alguna duda mientras estás trabajando en casa con Excel, ya tienes a quien preguntar.

    Espero que esta medida te sirva de ayuda. Frenar la expansión del coronavirus depende de todos. Sé responsable.

Marcos14

ANSWERED Como redimensionar UserForm automáticamente al hacer doble click en un textbox

Recommended Posts

Hace 1 minuto , JSDJSD dijo:

Bueno ahora en cuanto pueda te lo subo, pero tengo que decirte  que únicamente he adaptado el código que te subió el Maestro Antoni

te lo agradezco mucho pero es que no he visto el codigo os pido disculpas pero es la verdad

Share this post


Link to post
Share on other sites
Hace 12 minutos , Marcos14 dijo:

Totalmente de acuerdo con tus palabras, yo soy de los que no sabe nada e intento aprender, casi todo lo que hay en la aplicacion que estoy intentando sacar adelante, a sido a fuerza de mirar muchas cosas por internet y agradezco toda la ayuda prestada por parte de todos, pero hay frases que sobran "Parodiando a mi amigo Haplox, me rindo. ", como esta

Yo también empece de cero como tú y te entiendo pero yo siempre he seguido los consejos de los demás sin cuestionarlos, cosa que a la larga te darás cuenta que te hacen mucho bien y siguiendo estos consejos puedo decirte que de una escala del 0 al 10 ahora mismo creo que puedo estar sobre un 2.5  pero estoy plenamente contento con mi progreso que cada día aumenta un poquito más.

Respecto a la frase que comentas en ningún caso debes tomartela a mal, simplemente te dan a entender que no comprenden lo que solicitas y te puedo asegurar que precisamente Antoni es uno de los miembros del foro que se preocupan de estar todos los días al pie del cañón para resolvernos a NOSOTROS en los que me incluyo yo, todos los problemas que planteamos.

Bueno no te caliento la cabeza más te dejo el archivo y si tienes algún problema no dudes en consultar.

https://mega.nz/#!62IBgAyb!Es3pm1qcLYtHunF3bxhF3JxXlWROwWHZ1AdVKMqnXTE

Share this post


Link to post
Share on other sites
Hace 16 minutos , JSDJSD dijo:

Yo también empece de cero como tú y te entiendo pero yo siempre he seguido los consejos de los demás sin cuestionarlos, cosa que a la larga te darás cuenta que te hacen mucho bien y siguiendo estos consejos puedo decirte que de una escala del 0 al 10 ahora mismo creo que puedo estar sobre un 2.5  pero estoy plenamente contento con mi progreso que cada día aumenta un poquito más.

Respecto a la frase que comentas en ningún caso debes tomartela a mal, simplemente te dan a entender que no comprenden lo que solicitas y te puedo asegurar que precisamente Antoni es uno de los miembros del foro que se preocupan de estar todos los días al pie del cañón para resolvernos a NOSOTROS en los que me incluyo yo, todos los problemas que planteamos.

Bueno no te caliento la cabeza más te dejo el archivo y si tienes algún problema no dudes en consultar.

https://mega.nz/#!62IBgAyb!Es3pm1qcLYtHunF3bxhF3JxXlWROwWHZ1AdVKMqnXTE

Si sirve de algo pido disculpas a todos y en especial a Antoni 

Share this post


Link to post
Share on other sites
Hace 8 minutos , JSDJSD dijo:

Bueno, prueba otra vez con el código a mi no me da error.

https://mega.nz/#!62IBgAyb!Es3pm1qcLYtHunF3bxhF3JxXlWROwWHZ1AdVKMqnXTE


Private Sub cmdBorrarDatos_Click()

EliminarDatos

End Sub
Sub EliminarDatos()
Dim Pregunta As String
    If Me.lst.ListIndex < 0 Then
        MsgBox "No se ha seleccionado ningún ítem.", vbExclamation, "SISTEMA DE FACTURACIÓN"
    Else
        Pregunta = MsgBox("Está seguro de eliminar el ítem seleccionado?", vbYesNo + vbQuestion, "SISTEMA DE FACTURACIÓN")
            If Pregunta <> vbNo Then
                ActiveCell.EntireRow.Delete
        
            End If
    End If

End Sub
Private Sub cmdGuardarDatos_Click()
If CmdGuardarDatos.Caption = "Guardar datos" Then
    Guardar
Else
    Modificar
End If
End Sub
Sub Guardar()
Dim NwRf As String, NmPr As String

NwRf = TxtRef
NmPr = TxtProducto

Prg = MsgBox("¿Desea guardar los datos de la referencia " & NwRf & " en este momento?", vbQuestion + vbYesNo, "SISTEMA DE FACTURACIÓN")

    If Prg <> vbNo Then
        Sheets("Partidas").Activate
        Range("b2").Select
        On Error Resume Next
        Range("b2:b1048576").Find(What:=NmPr, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=True).Activate
        If ActiveCell.Value = NmPr Then
            Qst = MsgBox("Ya existe un producto con el nombre " & Chr(34) & NmPr & Chr(34) & " registrado en la base de datos!" & Chr(10) & _
                "¿Desea registrar de todas formas?", vbQuestion + vbYesNo, "SISTEMA DE FACTURACIÓN")
                If Qst <> vbNo Then
                    Range("a1048576").End(xlUp).Offset(1, 0).Select
                    ActiveCell.Value = NwRf
                    ActiveCell.Offset(0, 1).Value = TxtProducto
                    ActiveCell.Offset(0, 2).Value = Val(TxtPrecio)
                    ActiveCell.Offset(0, 3).Value = TxtStock
                    Range("PartConsec").Value = Range("PartConsec").Value + 1
                    CargaPartidas
                    Limpiar
                    CarNwRf
                    MsgBox "La referencia " & NwRf & ", ha sido registrada con éxito!", vbInformation, "SISTEMA DE FACTURACIÓN"
                End If
                
        Else
                
            Range("a1048576").End(xlUp).Offset(1, 0).Select
            ActiveCell.Value = NwRf
            ActiveCell.Offset(0, 1).Value = TxtProducto
            ActiveCell.Offset(0, 2).Value = Val(TxtPrecio)
            ActiveCell.Offset(0, 3).Value = TxtStock
            Range("PartConsec").Value = Range("PartConsec").Value + 1
            CargaPartidas
            Limpiar
            CarNwRf
            MsgBox "La referencia " & NwRf & ", ha sido registrada con éxito!", vbInformation, "SISTEMA DE FACTURACIÓN"
            
        End If
    End If
End Sub
Sub Modificar()
Dim Fila As String, RfUd As String, Cnt As Integer
RfUd = TxtRef
Cnt = Val(TxtCant)

If Cnt = 0 Then
    MsgBox "Ingrese la cantidad de stock a registrar en almacén por favor!", vbInformation, "SISTEMA DE FACTURACIÓN"
Else

Qst = MsgBox("¿Desea modificar la referencia " & RfUd & " en este momento?", vbQuestion + vbYesNo, "SISTEMA DE FACTURACIÓN")
    If Qst <> vbNo Then

        Sheets("Partidas").Activate
        Fila = Range("PartConsec").Value 'esta linea, toma el numero de la fila anterior para asignar el numero al producto
        On Error Resume Next
        Range("a2:a1048576").Find(What:=RfUd, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=True).Activate
        ActiveCell.Offset(0, 1).Value = TxtProducto
        ActiveCell.Offset(0, 2).Value = Val(TxtPrecio)
        ActiveCell.Offset(0, 3).Value = ActiveCell.Offset(0, 3).Value + Val(TxtCant)
        
        CargaPartidas
        MsgBox "La referencia " & RfUd & ", ha sido modificada con éxito!", vbInformation, "SISTEMA DE FACTURACIÓN"
        Limpiar
        CarNwRf
    End If
End If
End Sub
Private Sub cmdSalir_Click()
Unload Me
End Sub

Private Sub ComboBox1_Change()
Dim RfUd As String
RfUd = ComboBox1.Value

Sheets("Partidas").Select
Range("a2").Activate
On Error Resume Next
Range("a2:a1048576").Find(What:=RfUd, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=True).Activate
        
        If ActiveCell.Value = RfUd Then
            TxtRef = ActiveCell.Value
'            ComboBox1.Value = ActiveCell.Value
            TxtProducto = ActiveCell.Offset(0, 1).Value
            TxtPrecio = ActiveCell.Offset(0, 2).Value
            TxtStock = ActiveCell.Offset(0, 3).Value
        Else
            MsgBox "Producto no encontrado!", vbCritical, "SISTEMA DE FACTURACIÓN"
        End If
End Sub

Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ComboBox1.Visible = False
ComboBox2.Visible = False
CmdGuardarDatos.Caption = "Guardar datos"
TxtCant.Visible = False
Label5.Visible = False
Limpiar
CarNwRf
End Sub

Private Sub ComboBox2_Change()
Dim Prd As String
Prd = ComboBox2.Value

Sheets("Partidas").Select
Range("b2").Select
On Error Resume Next
Range("b2:b1048576").Find(What:=Prd, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=True).Activate
        
        If ActiveCell.Value = Prd Then
            TxtRef = ActiveCell.Offset(0, -1).Value
'            ComboBox1.Value = ActiveCell.Offset(0, -1).Value
            TxtPrecio = ActiveCell.Offset(0, 1).Value
            TxtStock = ActiveCell.Offset(0, 2).Value
        Else
            MsgBox "Producto no encontrado!", vbCritical, "SISTEMA DE FACTURACIÓN"
        End If

End Sub

Private Sub ComboBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ComboBox1.Visible = False
ComboBox2.Visible = False
CmdGuardarDatos.Caption = "Guardar datos"
TxtCant.Visible = False
Label5.Visible = False
Limpiar
CarNwRf
End Sub

Private Sub lst_Click()
Dim Cuenta As Integer, i As Variant, Valor As String
On Error Resume Next
Sheets("Partidas").Select
    Range("a2").Activate
    Cuenta = Me.lst.ListCount
    For i = 0 To Cuenta - 1
        If Me.lst.Selected(i) Then
            'MsgBox Me.ListBox1.List(i)
            Valor = Me.lst.List(i)
            Sheets("Partidas").Range("a2:a1048576").Find(What:=Valor, LookAt:=xlWhole, After:=ActiveCell).Activate
        End If
    Next i
End Sub

Private Sub TxtCant_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii < 45 Or KeyAscii > 57 Then
KeyAscii = 0
End If

End Sub

Private Sub txtPrecio_Exit(ByVal Cancel As MSForms.ReturnBoolean)
TxtPrecio = Format(Val(TxtPrecio), "#,###.##")
TxtPrecio = Format(TxtPrecio, "currency")
End Sub
Sub Limpiar()
    
    TxtProducto = ""
    TxtPrecio = ""
    TxtStock = ""
    TxtCant = ""
    ComboBox1 = ""
    ComboBox2 = ""
    ComboBox1.Visible = False
    ComboBox2.Visible = False
    CmdGuardarDatos.Caption = "Guardar datos"
    
End Sub

Private Sub txtPrecio_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii < 45 Or KeyAscii > 57 Then
KeyAscii = 0
End If

End Sub

Private Sub txtProducto_Change()
Dim i As Integer
TxtProducto.Text = UCase(TxtProducto.Text)
i = Len(TxtProducto.Text)
TxtProducto.SelStart = i

End Sub


Private Sub TxtProducto_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ComboBox1.Visible = False
ComboBox2.Visible = True
CmdGuardarDatos.Caption = "Modificar datos"
TxtCant.Visible = True
Label5.Visible = True
End Sub


Private Sub TxtRef_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ComboBox1.Visible = True
ComboBox2.Visible = False
CmdGuardarDatos.Caption = "Modificar datos"
TxtCant.Visible = True
Label5.Visible = True
End Sub

Private Sub txtStock_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii < 45 Or KeyAscii > 57 Then
KeyAscii = 0
End If

End Sub

Private Sub UserForm_Click()
Dim NewHeight As Single
    NewHeight = Height
If NewHeight = Val(Tag) Then
        Height = Val(Tag) * 2
    Else
Height = Val(Tag)
    End If
End Sub

Private Sub UserForm_Initialize()
UserForm1.Caption = "Click r!"
    Tag = Height    ' Mantener el tamaño inicial.
Me.Caption = "Trabajos o Productos - SISTEMA DE FACTURACIÓN "
CargaPartidas
CarRef
CarPrds
CarNwRf
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then Cancel = True
End Sub
Sub CargaPartidas()
Dim strTabla As String, rngMirango As Range, rngMirango2 As Range, intColumnas As Integer
Sheets("Partidas").Select
strTabla = "TrabajosPartidas"

On Error Resume Next
'Creamos el nombre a la tabla de la hoja activa

ActiveWorkbook.Names(strTabla).Delete
Set rngMirango = ActiveSheet.Range("A1").CurrentRegion
Set rngMirango2 = rngMirango.Offset(1, 0).Resize(rngMirango.Rows.Count - 1, rngMirango.Columns.Count)
rngMirango2.Name = strTabla
intColumnas = rngMirango2.Columns.Count
'
'Formateamos ListBox
'
With lst
    .ColumnCount = intColumnas
    .ColumnWidths = "60 pt;160 pt;80 pt;60 pt;60 pt;0 pt;0 pt;0 pt;0 pt;180 pt;0 pt;0 pt;0 pt;0 pt;0 pt;0 pt;0 pt;0 pt;0 pt;60 pt;0 pt;0 pt;60 pt;85 pt;100 pt;80 pt;80 pt"
'                    1     2      3    4     5     6   7    8    9     10    11  12   13   14   15   16   17   18   19   20    21  22    23    24    25     26     27
    .ColumnHeads = True
End With
lst.RowSource = strTabla

End Sub
Sub CarRef()
ComboBox1.Clear
Sheets("Partidas").Activate
Range("a2").Select
Do While ActiveCell <> ""
    ComboBox1.AddItem ActiveCell
    ActiveCell.Offset(1, 0).Select
Loop
End Sub
Sub CarPrds()
ComboBox2.Clear
Sheets("Partidas").Activate
Range("b2").Select
Do While ActiveCell <> ""
    ComboBox2.AddItem ActiveCell
    ActiveCell.Offset(1, 0).Select
Loop
End Sub
Sub CarNwRf()
Dim Fila As String, NwRf As String
Fila = Range("PartConsec").Value 'esta linea, toma el numero de la fila anterior para asignar el numero al producto
NwRf = "SF-" & Format(Fila, "0000")
TxtRef = NwRf
End Sub

Private Sub UserForm_Resize()
UserForm1.Caption = "New Height: " & Height & "  " & "Click to resize me!"
End Sub
Private Sub TxtProducto_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ComboBox1.Visible = False
ComboBox2.Visible = True
CmdGuardarDatos.Caption = "Modificar datos"
TxtCant.Visible = True
Label5.Visible = True
'Me.Width = 450
End Sub


Private Sub TxtRef_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ComboBox1.Visible = True
ComboBox2.Visible = False
CmdGuardarDatos.Caption = "Modificar datos"
TxtCant.Visible = True
Label5.Visible = True
Me.Width = 450
UserForm1.lst.Width = 417.45
End Sub
 

Este es todo el codigo del userform dime si me he dejado algo cuando puedas

Share this post


Link to post
Share on other sites
Guest
This topic is now closed to further replies.



×
×
  • Create New...

Important Information

Privacy Policy


CTA Templates.png