Agregar, Eliminar, Guardar, Listar y Actualizar partidas en ListView VBA

 

Operaciones con ListView 6.00 VBA

Diseñamos un userform y escribimos el siguiente código:

Public stridentidad As String

Public intindex As Integer

Private Sub UserForm_Initialize()

On Error GoTo Errores

PersonalizarListView

Errores:

If Err.Number <> 0 Then

    MsgBox "Se ha producido un error" & vbNewLine & "Error número: " & Err.Number & vbNewLine & "Descripción: " & Err.Description & "", vbOKOnly + vbExclamation, "Error"

End If

End Sub

Private Sub txtclave_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

On Error GoTo Errores

If KeyCode = 114 Then

    Me.txtrecibido.BackColor = RGB(94, 255, 51)

    Me.txtrecibido.Enabled = True

    Me.txtrecibido.SetFocus

End If

Errores:

If Err.Number <> 0 Then

    MsgBox "Se ha producido un error" & vbNewLine & "Error número: " & Err.Number & vbNewLine & "Descripción: " & Err.Description & "", vbOKOnly + vbExclamation, "Error"

End If

End Sub

Private Sub txtcantidad_Exit(ByVal Cancel As MSForms.ReturnBoolean)

If Not IsNumeric(Me.txtcantidad.Text) Or Me.txtcantidad.Value = 0 Then

    Cancel = True

    Me.txtcantidad.SetFocus

    MsgBox "Capture una cantidad", vbOKOnly + vbInformation, "Cantidad"

End If

End Sub

Private Sub txtcantidad_Change()

On Error Resume Next

If Me.txtcantidad.Text > 0 Then Me.cmdagregar.Enabled = True

If Me.txtcantidad.Text <> 0 Then Me.cmdagregar.Enabled = False

ImportePartida

On Error GoTo 0

End Sub

Private Sub txtcantidad_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

On Error GoTo Errores

If KeyCode = 13 Then

    AgregarPartida

End If

Errores:

If Err.Number <> 0 Then

    MsgBox "Se ha producido un error" & vbNewLine & "Error número: " & Err.Number & vbNewLine & "Descripción: " & Err.Description & "", vbOKOnly + vbExclamation, "Error"

End If

End Sub

Private Sub txtprecio_Exit(ByVal Cancel As MSForms.ReturnBoolean)

If Not IsNumeric(Me.txtprecio.Text) Or Me.txtprecio.Value = 0 Then

    Cancel = True

    Me.txtprecio.SetFocus

    MsgBox "Capture un precio", vbOKOnly + vbInformation, "Cantidad"

End If

End Sub

Private Sub txtprecio_Change()

On Error Resume Next

If Me.txtprecio.Text > 0 Then Me.cmdagregar.Enabled = True

If Me.txtprecio.Text <> 0 Then Me.cmdagregar.Enabled = False

ImportePartida

On Error GoTo 0

End Sub

Private Sub txtprecio_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

On Error GoTo Errores

If KeyCode = 13 Then

    AgregarPartida

End If

Errores:

If Err.Number <> 0 Then

    MsgBox "Se ha producido un error" & vbNewLine & "Error número: " & Err.Number & vbNewLine & "Descripción: " & Err.Description & "", vbOKOnly + vbExclamation, "Error"

End If

End Sub

Private Sub txtdescuento_Exit(ByVal Cancel As MSForms.ReturnBoolean)

If Not IsNumeric(Me.txtdescuento.Text) Then

    Cancel = True

    Me.txtdescuento.SetFocus

    MsgBox "Capture un descuento", vbOKOnly + vbInformation, "Descuento"

End If

End Sub

Private Sub txtdescuento_Change()

On Error Resume Next

ImportePartida

On Error GoTo 0

End Sub

Private Sub txtdescuento_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

On Error GoTo Errores

If KeyCode = 13 Then

    AgregarPartida

End If

Errores:

If Err.Number <> 0 Then

    MsgBox "Se ha producido un error" & vbNewLine & "Error número: " & Err.Number & vbNewLine & "Descripción: " & Err.Description & "", vbOKOnly + vbExclamation, "Error"

End If

End Sub

Private Sub cmdagregar_Click()

AgregarPartida

End Sub

Private Sub cmdeliminar_Click()

On Error GoTo Errores

EliminarPartida

Errores:

If Err.Number <> 0 Then

    MsgBox "Se ha producido un error" & vbNewLine & "Error número: " & Err.Number & vbNewLine & "Descripción: " & Err.Description & "", vbOKOnly + vbExclamation, "Error"

End If

End Sub

Private Sub cmdnuevo_Click()

Me.ListView1.ListItems.Clear

Me.cmdagregar.Enabled = False

Me.cmdeliminar.Enabled = False

Me.cmdnuevo.Enabled = False

Me.cmdguardar.Enabled = False

Me.cmdbuscar.Enabled = False

Me.cmdactualizar.Enabled = False

End Sub

Private Sub cmdguardar_Click()

Dim lngultfil As Long

Dim intfila As Integer

Dim ws As Worksheet

On Error GoTo Errores

If MsgBox("¿Los datos son correctos?", vbYesNo + vbQuestion, "Antes de continuar") = vbNo Then MsgBox "No se guardó nada", vbOKOnly + vbExclamation, "Exclamation": Exit Sub

Set ws = Worksheets("Hoja1")

'1ra forma recorrer partidas en un ListView

For intfila = 1 To Me.ListView1.ListItems.Count

    lngultfil = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

    ws.Cells(lngultfil, 1).Value = lngultfil - 1

    ws.Cells(lngultfil, 2).Value = Me.ListView1.ListItems(intfila).ListSubItems(2)

    ws.Cells(lngultfil, 3).Value = Me.ListView1.ListItems(intfila).ListSubItems(3)

    ws.Cells(lngultfil, 4).Value = Me.ListView1.ListItems(intfila).ListSubItems(4)

    ws.Cells(lngultfil, 5).Value = Me.ListView1.ListItems(intfila).ListSubItems(5)

    ws.Cells(lngultfil, 6).Value = Me.ListView1.ListItems(intfila).ListSubItems(6)

    ws.Cells(lngultfil, 7).Value = Me.ListView1.ListItems(intfila).ListSubItems(7)

    ws.Cells(lngultfil, 8).Value = Me.ListView1.ListItems(intfila).ListSubItems(8)

    ws.Cells(lngultfil, 9).Value = "VIGENTE"

Next intfila

MsgBox "El registro fue guardado correctamente", vbOKOnly + vbInformation, "Información"

Me.ListView1.ListItems.Clear

Me.cmdnuevo.Enabled = True

Me.cmdguardar.Enabled = False

Me.cmdbuscar.Enabled = True

Me.cmdactualizar.Enabled = False

Errores:

If Err.Number <> 0 Then

    MsgBox "Se ha producido un error" & vbNewLine & "Error número: " & Err.Number & vbNewLine & "Descripción: " & Err.Description & "", vbOKOnly + vbExclamation, "Error"

End If

End Sub

Private Sub cmdbuscar_Click()

Dim lngultfil As Long

Dim intfila As Integer

Dim lstItem As ListItem

Dim ws As Worksheet

On Error GoTo Errores

Me.ListView1.ListItems.Clear

Set ws = Worksheets("Hoja1")

lngultfil = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row - 1

'1ra forma

For intfila = 2 To lngultfil

    If ws.Cells(intfila, 9) = "VIGENTE" Then

        Set lstItem = Me.ListView1.ListItems.Add(Text:=0)

        lstItem.ListSubItems.Add Text:=ws.Cells(intfila, 1)

        lstItem.ListSubItems.Add Text:=ws.Cells(intfila, 2)

        lstItem.ListSubItems.Add Text:=FormatNumber(ws.Cells(intfila, 3), 3)

        lstItem.ListSubItems.Add Text:=ws.Cells(intfila, 4)

        lstItem.ListSubItems.Add Text:=ws.Cells(intfila, 5)

        lstItem.ListSubItems.Add Text:=FormatNumber(ws.Cells(intfila, 6), 4)

        lstItem.ListSubItems.Add Text:=FormatNumber(ws.Cells(intfila, 7), 2)

        lstItem.ListSubItems.Add Text:=FormatNumber(ws.Cells(intfila, 8), 2)

    End If

Next intfila

RealizarSuma

Me.cmdnuevo.Enabled = True

Me.cmdguardar.Enabled = False

Me.cmdbuscar.Enabled = False

Me.cmdactualizar.Enabled = True

Errores:

If Err.Number <> 0 Then

    MsgBox "Se ha producido un error" & vbNewLine & "Error número: " & Err.Number & vbNewLine & "Descripción: " & Err.Description & "", vbOKOnly + vbExclamation, "Error"

End If

End Sub

Private Sub cmdactualizar_Click()

Dim intide As Integer

Dim rng1 As Range

On Error GoTo Errores

'Poner cancelado a las partidas eliminadas de ListView

For intide = 1 To intcontador

    Set rng1 = Hoja1.Range("A:A").Find(What:=stridepartid(intide), LookAt:=xlWhole, LookIn:=xlValues)

    If rng1 Is Nothing Then

        MsgBox "El id no existe", vbOKOnly + vbInformation, "No encontrado"

    Else

        Hoja1.Range("I" & rng1.Row) = "CANCELADO"

    End If

Next intide

intcontador = 0

'Agregamos o modificamos los registros

'2da forma recorrer filas en ListView

Dim rngrango As Range

Dim intfila As Integer

Dim lngultfil As Long

Dim strpartid As String

With Sheets("Hoja1")

    For intfila = 1 To Me.ListView1.ListItems.Count

        strpartid = Me.ListView1.ListItems.Item(intfila).SubItems(1)

        'Buscar registro

        Set rng1 = Hoja1.Range("A:A").Find(What:=strpartid, LookAt:=xlWhole, LookIn:=xlValues)

        If rng1 Is Nothing Then

            'Si no existe el registro lo da de alta

            Set rngrango = Sheets("Hoja1").Range("A1").CurrentRegion

            lngultfil = rngrango.Rows.Count + 1

            .Cells(lngultfil, 1).Value = lngultfil - 1

            .Cells(lngultfil, 2).Value = Me.ListView1.ListItems.Item(intfila).SubItems(2)

            .Cells(lngultfil, 3).Value = Me.ListView1.ListItems.Item(intfila).SubItems(3)

            .Cells(lngultfil, 4).Value = Me.ListView1.ListItems.Item(intfila).SubItems(4)

            .Cells(lngultfil, 5).Value = Me.ListView1.ListItems.Item(intfila).SubItems(5)

            .Cells(lngultfil, 6).Value = Me.ListView1.ListItems.Item(intfila).SubItems(6)

            .Cells(lngultfil, 7).Value = Me.ListView1.ListItems.Item(intfila).SubItems(7)

            .Cells(lngultfil, 8).Value = Me.ListView1.ListItems.Item(intfila).SubItems(8)

            .Cells(lngultfil, 9).Value = "VIGENTE"

        Else

            'Si existe el registro lo modifica

            Hoja1.Range("C" & rng1.Row) = Me.ListView1.ListItems.Item(intfila).SubItems(3)

            Hoja1.Range("F" & rng1.Row) = Me.ListView1.ListItems.Item(intfila).SubItems(6)

            Hoja1.Range("G" & rng1.Row) = Me.ListView1.ListItems.Item(intfila).SubItems(7)

            Hoja1.Range("H" & rng1.Row) = Me.ListView1.ListItems.Item(intfila).SubItems(8)

        End If

    Next intfila

End With

MsgBox "El registro fué actualizado", vbOKOnly + vbInformation, "Información"

'Poner cancelado a las partidas eliminadas

Me.cmdnuevo.Enabled = True

Me.cmdguardar.Enabled = False

Me.cmdbuscar.Enabled = True

Me.cmdactualizar.Enabled = False

Errores:

If Err.Number <> 0 Then

    MsgBox "Se ha producido un error" & vbNewLine & "Error número: " & Err.Number & vbNewLine & "Descripción: " & Err.Description & "", vbOKOnly + vbExclamation, "Error"

End If

End Sub

Private Sub txtrecibido_Change()

On Error Resume Next

If Not IsNumeric(Me.txtrecibido.Value) Then Exit Sub

If Me.txtrecibido.Text > 0 Then Me.txtcambio.Text = Format(Me.txtrecibido.Text - Me.txttotalfin.Text, "##,##0.00")

On Error GoTo 0

End Sub

Private Sub txtrecibido_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

On Error GoTo Errores

If KeyCode = 13 Then

    Call cmdguardar_Click

End If

Errores:

If Err.Number <> 0 Then

    MsgBox "Se ha producido un error" & vbNewLine & "Error número: " & Err.Number & vbNewLine & "Descripción: " & Err.Description & "", vbOKOnly + vbExclamation, "Error"

End If

End Sub

Private Sub ListView1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)

  With ListView1

       If .SortOrder = lvwAscending Then

          .SortOrder = lvwDescending

       Else

          .SortOrder = lvwAscending

       End If

       .Sorted = True

       .SortKey = 1

  End With

End Sub

Private Sub ListView1_DblClick()

On Error GoTo Errores

If Me.ListView1.ListItems.Count = 0 Then Exit Sub

intindex = Me.ListView1.SelectedItem.Index

'1ra forma

With Me.ListView1

    Me.txtidenti.Text = .SelectedItem.SubItems(1)

    Me.txtclave.Value = .SelectedItem.SubItems(2)

    Me.txtcantidad.Value = .SelectedItem.SubItems(3)

    Me.txtunidad.Value = .SelectedItem.SubItems(4)

    Me.txtnombre.Value = .SelectedItem.SubItems(5)

    Me.txtprecio.Value = .SelectedItem.SubItems(6)

    Me.txtdescuento.Value = .SelectedItem.SubItems(7)

    Me.txtimporte.Value = .SelectedItem.SubItems(8)

End With

'2da forma

Me.txtidenti.Text = Me.ListView1.SelectedItem.ListSubItems(1)

Me.txtclave.Text = Me.ListView1.SelectedItem.ListSubItems(2)

Me.txtcantidad.Text = FormatNumber(Me.ListView1.SelectedItem.ListSubItems(3), 3)

Me.txtunidad.Text = Me.ListView1.SelectedItem.ListSubItems(4)

Me.txtnombre.Text = Me.ListView1.SelectedItem.ListSubItems(5)

Me.txtprecio.Text = FormatNumber(Me.ListView1.SelectedItem.ListSubItems(6), 4)

Me.txtdescuento.Text = FormatNumber(Me.ListView1.SelectedItem.ListSubItems(7), 2)

Me.txtimporte.Text = FormatNumber(Me.ListView1.SelectedItem.ListSubItems(8), 2)

'3ra forma

With Me.ListView1

    Me.txtidenti.Text = .SelectedItem.ListSubItems.Item(1)

    Me.txtclave.Value = .SelectedItem.ListSubItems.Item(2)

    Me.txtcantidad.Value = .SelectedItem.ListSubItems.Item(3)

    Me.txtunidad.Value = .SelectedItem.ListSubItems.Item(4)

    Me.txtnombre.Value = .SelectedItem.ListSubItems.Item(5)

    Me.txtprecio.Value = .SelectedItem.ListSubItems.Item(6)

    Me.txtdescuento.Value = .SelectedItem.ListSubItems.Item(7)

    Me.txtimporte.Value = .SelectedItem.ListSubItems.Item(8)

End With

Me.txtclave.Enabled = False

Me.txteditar.Text = "SI"

Errores:

If Err.Number <> 0 Then

    MsgBox "Se ha producido un error" & vbNewLine & "Error número: " & Err.Number & vbNewLine & "Descripción: " & Err.Description & "", vbOKOnly + vbExclamation, "Error"

End If

End Sub

Private Sub ListView1_AfterLabelEdit(Cancel As Integer, NewString As String)

Me.ListView1.SelectedItem.SubItems(3) = NewString

Cancel = True

RealizarSuma

End Sub

Private Sub PersonalizarListView()

'1ra forma encabezados de ListView

With Me.ListView1

    .ListItems.Clear

    .ColumnHeaders.Add(, , "", 0, lvwColumnLeft).Tag = "STRING"

    .ColumnHeaders.Add(, , "Id", 20, lvwColumnLeft).Tag = "STRING"

    .ColumnHeaders.Add(, , "Código", 60, lvwColumnLeft).Tag = "STRING"

    .ColumnHeaders.Add(, , "Cantidad", 60, lvwColumnRight).Tag = "NUMBER"

    .ColumnHeaders.Add(, , "Unidad", 50, lvwColumnRight).Tag = "NUMBER"

    .ColumnHeaders.Add(, , "Nombre", 150, lvwColumnLeft).Tag = "STRING"

    .ColumnHeaders.Add(, , "Precio", 70, lvwColumnRight).Tag = "NUMBER"

    .ColumnHeaders.Add(, , "Descue", 50, lvwColumnRight).Tag = "NUMBER"

    .ColumnHeaders.Add(, , "Importe", 70, lvwColumnRight).Tag = "NUMBER"

    .ColumnHeaders.Add(, , "", 0, lvwColumnLeft).Tag = "STRING"

    .Font.Size = 11

End With

'2da forma encabezados de ListView

With Me.ListView1

    .ListItems.Clear

    .Font.Size = 11

    With .ColumnHeaders

         .Clear

         .Add Text:="", Width:=0, Alignment:=fmAligmentLeft

         .Add Text:="Id", Width:=20, Alignment:=fmAligmentLeft

         .Add Text:="Código", Width:=60, Alignment:=fmAligmentLeft

         .Add Text:="Cantidad", Width:=60, Alignment:=lvwColumnRight

         .Add Text:="Unidad", Width:=50, Alignment:=fmAligmentLeft

         .Add Text:="Nombre", Width:=150, Alignment:=fmAligmentLeft

         .Add Text:="Precio", Width:=70, Alignment:=lvwColumnRight

         .Add Text:="Descue", Width:=50, Alignment:=lvwColumnRight

         .Add Text:="Importe", Width:=70, Alignment:=lvwColumnRight

         .Add Text:="", Width:=0, Alignment:=lvwColumnLeft

    End With

End With

'Visualización de los datos en forma de reporte

Me.ListView1.View = lvwReport

'Visualizar Líneas

Me.ListView1.Gridlines = True

'Resaltar Fila al Seleccionarla

Me.ListView1.FullRowSelect = True

'Edita la celda de forma automática

Me.ListView1.LabelEdit = lvwAutomatic

'Borde del control

Me.ListView1.Appearance = ccFlat

End Sub

Private Sub AgregarPartida()

Dim lngiden As Long

Dim strclav As String

Dim intfila As Integer

Dim lstItem As ListItem

On Error GoTo Errores

If Not IsNumeric(Me.txtcantidad.Text) Then Exit Sub

If Not IsNumeric(Me.txtdescuento.Text) Then Exit Sub

If Not IsNumeric(Me.txtprecio.Text) Then Exit Sub

If Me.txtcantidad.Text = 0 Then Exit Sub

If Me.txtprecio.Text = 0 Then Exit Sub

If Me.txteditar.Text = "SI" Then

    '1ra forma editar partida

    'For intfila = 1 To Me.ListView1.ListItems.Count

    '    lngiden = Me.ListView1.ListItems.Item(intfila).SubItems(1)

    '    If lngiden = Me.txtidenti.Text Then

    '        Me.ListView1.ListItems.Item(intfila).SubItems(3) = FormatNumber(Me.txtcantidad.Text, 3)

    '        Me.ListView1.ListItems.Item(intfila).SubItems(6) = FormatNumber(Me.txtprecio.Text, 4)

    '        Me.ListView1.ListItems.Item(intfila).SubItems(7) = FormatNumber(Me.txtdescuento.Text, 2)

    '        Me.ListView1.ListItems.Item(intfila).SubItems(8) = FormatNumber(Me.txtimporte.Text, 2)

    '    End If

    'Next intfila

    '2da forma editar partida

    Me.ListView1.ListItems.Item(intindex).SubItems(3) = FormatNumber(Me.txtcantidad.Text, 3)

    Me.ListView1.ListItems.Item(intindex).SubItems(6) = FormatNumber(Me.txtprecio.Text, 4)

    Me.ListView1.ListItems.Item(intindex).SubItems(7) = FormatNumber(Me.txtdescuento.Text, 2)

    Me.ListView1.ListItems.Item(intindex).SubItems(8) = FormatNumber(Me.txtimporte.Text, 2)

Else

    GenerarCadena

    '1ra forma agregar partida

    Set lstItem = Me.ListView1.ListItems.Add(, , 0)

    lstItem.SubItems(1) = stridentidad

    lstItem.SubItems(2) = Me.txtclave.Text

    lstItem.SubItems(3) = FormatNumber(Me.txtcantidad.Text, 3)

    lstItem.SubItems(4) = Me.txtunidad.Text

    lstItem.SubItems(5) = Me.txtnombre.Text

    lstItem.SubItems(6) = FormatNumber(Me.txtprecio.Text, 4)

    lstItem.SubItems(7) = FormatNumber(Me.txtdescuento.Text, 2)

    lstItem.SubItems(8) = FormatNumber(Me.txtimporte.Text, 2)

    '2da forma agregar partida

    'Set lstItem = Me.ListView1.ListItems.Add(Text:=0)

    'lstItem.ListSubItems.Add Text:=stridentidad

    'lstItem.ListSubItems.Add Text:=Me.txtclave.Text

    'lstItem.ListSubItems.Add Text:=Format(Me.txtcantidad.Value, "##,##0.000")

    'lstItem.ListSubItems.Add Text:=Me.txtunidad.Value

    'lstItem.ListSubItems.Add Text:=Me.txtnombre.Value

    'lstItem.ListSubItems.Add Text:=Format(Me.txtprecio.Value, "##,##0.0000")

    'lstItem.ListSubItems.Add Text:=Format(Me.txtdescuento.Value, "##,##0.00")

    'lstItem.ListSubItems.Add Text:=Format(Me.txtimporte.Value, "##,##0.00")

End If

Me.txtidenti.Text = 0

Me.txteditar.Text = "NO"

Me.txtclave.Enabled = True

RealizarSuma

Me.txtclave.SetFocus

Me.txtclave.Text = Clear

Me.txtcantidad.Text = 0

Me.txtunidad.Text = Empty

Me.txtnombre.Text = Empty

Me.txtprecio.Text = 0

Me.txtdescuento.Text = 0

Me.txtimporte.Text = 0

If Me.ListView1.ListItems.Count >= 1 Then Me.cmdguardar.Enabled = True: Me.cmdeliminar.Enabled = True: Me.cmdbuscar.Enabled = False

Errores:

If Err.Number <> 0 Then

    MsgBox "Se ha producido un error" & vbNewLine & "Error número: " & Err.Number & vbNewLine & "Descripción: " & Err.Description & "", vbOKOnly + vbExclamation, "Error"

End If

End Sub

Private Sub EliminarPartida()

Dim intcont As Integer

On Error GoTo Errores

'1ra forma

If Me.ListView1.ListItems.Count <> 0 Then

    'Tomamos la partida para ponerle CANCELADO

    intcontador = intcontador + 1

    ReDim Preserve stridepartid(intcontador) As String

    stridepartid(intcontador) = Me.ListView1.SelectedItem.ListSubItems(1)

    'Elimina la partida de ListView

    Me.ListView1.ListItems.Remove Me.ListView1.SelectedItem.Index

Else

    MsgBox "No hay nada que eliminar", vbInformation, "Eliminar"

End If

'2da forma

'If Me.ListView1.ListItems.Count = 0 Then Me.cmdguardar.Enabled = False: Exit Sub

'intcont = Me.ListView1.SelectedItem.Index

'Me.ListView1.ListItems.Remove (intcont)

If Me.ListView1.ListItems.Count = 0 Then

    Me.cmdagregar.Enabled = True

    Me.cmdeliminar.Enabled = False

    Me.cmdguardar.Enabled = False

    Me.cmdbuscar.Enabled = False

    Me.cmdactualizar.Enabled = False

End If

RealizarSuma

Errores:

If Err.Number <> 0 Then

    MsgBox "Se ha producido un error" & vbNewLine & "Error número: " & Err.Number & vbNewLine & "Descripción: " & Err.Description & "", vbOKOnly + vbExclamation, "Error"

End If

End Sub

Private Sub ImportePartida()

Dim curprecio As Currency

On Error GoTo Errores

If Not IsNumeric(Me.txtcantidad.Text) Then Me.cmdagregar.Enabled = False

If Not IsNumeric(Me.txtdescuento.Text) Then Me.cmdagregar.Enabled = False

If Not IsNumeric(Me.txtprecio.Text) Then Me.cmdagregar.Enabled = False

If Me.txtcantidad.Text = 0 Then Me.cmdagregar.Enabled = False

If Me.txtprecio.Text = 0 Then Me.cmdagregar.Enabled = False

If Me.txtdescuento.Text = 0 Then Me.cmdagregar.Enabled = False

If Me.txtcantidad.Text > 0 Then Me.cmdagregar.Enabled = True

If Me.txtprecio.Text > 0 Then Me.cmdagregar.Enabled = True

curprecio = Format(Me.txtprecio.Text - (Me.txtprecio.Text * (Me.txtdescuento.Text / 100)), "##,##0.0000")

Me.txtimporte.Text = Format(Me.txtcantidad.Text * curprecio, "##,##0.0000")

Errores:

If Err.Number <> 0 Then

    Me.txtimporte.Text = 0

End If

End Sub

Private Sub RealizarSuma()

Dim intfila As Integer

Dim cur_cantid As Currency

Dim cur_precio As Currency

Dim cur_descue As Currency

Dim curimporte As Currency

Dim cur_cantfi As Currency

Dim cur_total As Currency

Dim curdescuen As Currency

Dim curtotalfi As Currency

On Error GoTo Errores

cur_total = 0

curdescuen = 0

curtotalfi = 0

For intfila = 1 To Me.ListView1.ListItems.Count

    cur_cantid = 0: cur_precio = 0:  cur_descue = 0: curimporte = 0

    cur_cantid = Format(Me.ListView1.ListItems(intfila).ListSubItems(3), "##,##0.0000")

    cur_precio = Format(Me.ListView1.ListItems(intfila).ListSubItems(6), "##,##0.0000")

    cur_descue = Format(Me.ListView1.ListItems(intfila).ListSubItems(7), "##,##0.0000")

    curimporte = Format(Me.ListView1.ListItems(intfila).ListSubItems(8), "##,##0.0000")

    cur_cantfi = cur_cantfi + cur_cantid

    cur_total = cur_total + (cur_cantid * cur_precio)

    curdescuen = curdescuen + (cur_cantid * (cur_precio * (cur_descue / 100)))

    curtotalfi = cur_total - curdescuen

Next intfila

Me.txttotal.Text = Format(cur_total, "##,##0.00")

Me.txtdescuent.Text = Format(curdescuen, "##,##0.00")

Me.txttotalfin.Text = Format(curtotalfi, "##,##0.00")

Me.lblregistros.Caption = "TOTAL DE PARTIDAS " & Me.ListView1.ListItems.Count

Me.lblarticulos.Caption = "TOTAL DE ARTICULOS " & Format(cur_cantfi, "##,##0.00")

Errores:

If Err.Number <> 0 Then

    MsgBox "Se ha producido un error" & vbNewLine & "Error número: " & Err.Number & vbNewLine & "Descripción: " & Err.Description & "", vbOKOnly + vbExclamation, "Error"

End If

End Sub

Private Sub GenerarCadena()

Dim intcont As Integer

Dim strcaracteres As String

strcaracteres = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"

For intcont = 1 To 10

    stridentidad = stridentidad & Mid(strcaracteres, Int((Len(strcaracteres) * Rnd) + 1), 1)

Next intcont

End Sub

Insertamos un Módulo y escribimos:

Public stridepartid() As String

Public intcontador As Integer

En la hoja1 de trabajo escribimos los que se muestra:

En Hoja1 se registra la información

Crear un menú y submenú en userform con VBA excel

Para poder lograrlo debemos seguir los siguientes pasos:

1.-Abrir un nuevo libro de trabajo e ir al editor de Microsoft Visual Bascic para Aplicaciones
2.-Ir al menú Insertar, Userform1.
3.-Agregamos una etiqueta Label1 y damos click derecho de la misma y escribimos el siguiente código;

Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim CmmBC_Menu As CommandBarControl
Dim CmmBC_Submenu As CommandBarControl
'Limpiamos el menú
Application.CommandBars("cell").Reset
Dim Op_Menu As CommandBarControl
'Ocultamos todos los menús como Copiar, Pegar, Insertar, Eliminar e.t.c del submenú clásico de excel
For Each Op_Menu In Application.CommandBars("cell").Controls
    Op_Menu.Visible = False
Next Op_Menu
'Agregamos el 1er Menú
Set CmmBC_Menu = Application.CommandBars("Cell").Controls.Add(Type:=msoControlPopup, before:=1)
CmmBC_Menu.Caption = "&Productos"
CmmBC_Menu.BeginGroup = True 'Colocamos un separador
'Agregamos el Submenú
Set CmmBC_Submenu = CmmBC_Menu.Controls.Add
CmmBC_Submenu.Caption = "&Kardex"
CmmBC_Submenu.FaceId = 762
CmmBC_Submenu.OnAction = "mKardex"
Set CmmBC_Submenu = CmmBC_Menu.Controls.Add
CmmBC_Submenu.Caption = "&Movimientos de inventario"
CmmBC_Submenu.FaceId = 1949
CmmBC_Submenu.OnAction = "mMovimientos"
Set CmmBC_Submenu = CmmBC_Menu.Controls.Add
CmmBC_Submenu.Caption = "&Lista de precios"
CmmBC_Submenu.FaceId = 1643
CmmBC_Submenu.OnAction = "mListaPrecios"
'Agregamos el 2do Menú
Set CmmBC_Menu = Application.CommandBars("Cell").Controls.Add(Type:=msoControlButton, before:=2)
CmmBC_Menu.Caption = "&Almacenes"
CmmBC_Menu.FaceId = 3743
CmmBC_Menu.OnAction = "mAlmacenes"
CmmBC_Menu.BeginGroup = True 'Colocamos un separador
'Agregamos el 3er Menú
Set CmmBC_Menu = Application.CommandBars("Cell").Controls.Add(Type:=msoControlButton, before:=3)
CmmBC_Menu.Caption = "&Existencias"
CmmBC_Menu.FaceId = 6025
CmmBC_Menu.OnAction = "mExistencias"
CmmBC_Menu.BeginGroup = True 'Colocamos un separador
'Cargamos y mostramos todo nuestro menú y submenú
Application.CommandBars("cell").ShowPopup
End Sub

Mediante el evento MouseMove se creará y mostrará nuestro menú.

4.-Damos clic en el menú Insertar, Módulo y en el escribimos el siguiente código:

Sub mKardex()

MsgBox "Aquí puedes agregar otra acción como cargar un formulario", vbOKOnly + vbInformation, "Kardex"

'Userform2.Show

End Sub

Sub mMovimientos()

MsgBox "Aquí puedes agregar otra acción como cargar un formulario", vbOKOnly + vbInformation, "Movimientos"

'Userform3.Show

End Sub

Sub mListaPrecios()

MsgBox "Aquí puedes agregar otra acción como cargar un formulario", vbOKOnly + vbInformation, "Lista de precios"

'Userform4.Show

End Sub

Sub mAlmacenes()

MsgBox "Aquí puedes agregar otra acción como cargar un formulario", vbOKOnly + vbInformation, "Almacenes"

'Userform5.Show

End Sub

Sub mExistencias()

MsgBox "Aquí puedes agregar otra acción como cargar un formulario", vbOKOnly + vbInformation, "Existencias"

'Userform6.Show

End Sub

Menú y Submenú en userform

Enviar un correo con outlook con macros excel

1.-Abrirmos VBA.

2.-Damos clic en Referencias e importamos la librería Microsoft Outlook y damos clic en Aceptar

Referencias VBA

3.-Configuramos el correo emisor desde Microsoft Outlook.

Microsoft Office Outlook

4.-Escribimos en un Modulo el siguiente código.

Sub EnviarPorCorreo()
Dim ProgCorreo, CorreoSaliente As Object
On Error GoTo Errores
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With
strmensaje = "Por medio de este correo se le hace llegar el documento correspondiente"
Set ProgCorreo = CreateObject("Outlook.Application")
Set CorreoSaliente = ProgCorreo.CreateItem(0)
On Error Resume Next
    With CorreoSaliente
        .To = pepito@hotmail.com 'Para
        '.CC = luis@gmail.com 'Con copia
        .Subject = "Factura A1000"
        .Body = "Estimado amigo buenos días le escribo para comentarle que le hago llegar su factura correspondiente"
        .Attachments.Add "C:\Users\Dell\Desktop\FacturaA1000.pdf"
        '1.-Enviar (.Send) ó 2.-Abrir ventana de outlook (.Display)
        .Display
    End With
On Error GoTo 0
Set CorreoSaliente = Nothing
Set ProgCorreo = Nothing
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With
Errores:
If Err.Number <> 0 Then
    MsgBox "Se ha producido un error" & vbNewLine & "Error número: " & Err.Number & vbNewLine & "Descripción: " & Err.Description & "", vbOKOnly + vbExclamation, "Error"
End If
End Sub

Diseñar un formato tamaño carta 27mm

 Sub FormatoCartaCarta()

'Selecciona todas las celda

Cells.Select

'Seleccionar fuente

With Selection.Font

.Name = "Calibri"

.Size = 11

End With

'Seleccionar alineacion ajustar al texto

With Selection

.HorizontalAlignment = xlGeneral

.VerticalAlignment = xlTop

End With

'Aplicar formato texto a toda la hoja

Selection.NumberFormat = "@"

Range("A1").Select

With ActiveSheet.PageSetup

'Definimos encabezado izquierdo fecha y hora

    .LeftHeader = "&D-&T"

'Definimos encabezado derecho página

    .RightHeader = "Página &P de &N"

'Definimos margen superior

    .TopMargin = Application.InchesToPoints(0.55)

'Definimos margen inferior

    .BottomMargin = Application.InchesToPoints(0.75)

'Definimos margen izquierdo

    .LeftMargin = Application.InchesToPoints(0.25)

'Definimos margen derecho

    .RightMargin = Application.InchesToPoints(0.25)

'Definimos margen del encabezado

    .HeaderMargin = Application.InchesToPoints(0.3)

'Definimos margen del pie de página

    .FooterMargin = Application.InchesToPoints(0.3)

End With

'Seleccionamos de la fila 1 a la 9 y cambiamos alineacion sin justar

Rows("1:15").Select

With Selection

    .HorizontalAlignment = xlGeneral

    .VerticalAlignment = xlTop

End With

    Columns("A:A").ColumnWidth = 0.5

    Columns("B:B").ColumnWidth = 0.58

    Columns("C:C").ColumnWidth = 14.14

    Columns("D:D").ColumnWidth = 8.43

    Columns("E:E").ColumnWidth = 41.71

    Columns("F:F").ColumnWidth = 10.14

    Columns("G:G").ColumnWidth = 4.71

    Columns("H:H").ColumnWidth = 11.71

    Rows("1:1").RowHeight = 8.25

'Combinar celdas

    Range("B2:H2").Select

    With Selection

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlTop

    End With

    Selection.Merge

    Range("B3:H3").Select

    With Selection

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlTop

    End With

    Selection.Merge

    Range("B4:H4").Select

    With Selection

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlTop

    End With

    Selection.Merge

    Range("B5:H5").Select

    With Selection

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlTop

    End With

    Selection.Merge

    Range("B6:H6").Select

    With Selection

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlTop

    End With

    Selection.Merge

    Range("B7:H7").Select

    With Selection

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlTop

    End With

    Selection.Merge

'Formato empresa y rfc

    Range("B2:H2").Select

    With Selection.Font

        .Name = "Tahoma"

        .Size = 12

    End With

    Selection.Font.Bold = True

    Range("B3:H3").Select

    Selection.Font.Bold = True

    With Selection.Font

        .Name = "Calibri"

        .Size = 12

    End With

    Selection.Font.Italic = True

'Colocar una autoforma

    ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 4.5, 4.5, 503, 104.25).Select

    Selection.ShapeRange.Fill.Visible = msoFalse

    With Selection.ShapeRange.Line

        .Visible = msoTrue

        .ForeColor.RGB = RGB(0, 32, 96)

        .Transparency = 0

    End With

    With Selection.ShapeRange.Line

        .Visible = msoTrue

        .Weight = 2.25

    End With

    ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 4.5, 113, 503, 80).Select

    Selection.ShapeRange.Fill.Visible = msoFalse

    With Selection.ShapeRange.Line

        .Visible = msoTrue

        .ForeColor.RGB = RGB(0, 32, 96)

        .Transparency = 0

    End With

    With Selection.ShapeRange.Line

        .Visible = msoTrue

        .Weight = 2.25

    End With

    Rows("14:14").RowHeight = 9

    ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 4.5, 198, 503, 16.75).Select

    Selection.ShapeRange.Fill.Visible = msoFalse

    With Selection.ShapeRange.Line

        .Visible = msoTrue

        .ForeColor.RGB = RGB(0, 32, 96)

        .Transparency = 0

    End With

    With Selection.ShapeRange.Line

        .Visible = msoTrue

        .Weight = 2.25

    End With

'Alineacion y fondo a titulo de partidas

    Range("B15:H15").Select

    With Selection

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlTop

    End With

    With Selection.Interior

        .Pattern = xlSolid

        .PatternColorIndex = xlAutomatic

        .Color = 49407

    End With

'Formato partidas

   Rows("16:10000").Select

    With Selection.Font

        .Name = "Calibri"

        .Size = 10

    End With

'Alineacion de precio,descuento,importe

    Range("F16:F10000").Select

    With Selection

        .HorizontalAlignment = xlRight

        .VerticalAlignment = xlTop

    End With

    Range("G16:G10000").Select

    With Selection

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlTop

    End With

    Range("H16:H10000").Select

    With Selection

        .HorizontalAlignment = xlRight

        .VerticalAlignment = xlTop

    End With

'Alto de fila

    Rows("2:2").RowHeight = 15

    Rows("3:3").RowHeight = 15.75

    Rows("4:4").RowHeight = 15

    Rows("5:5").RowHeight = 19.5

    Rows("6:6").RowHeight = 19.5

    Rows("7:7").RowHeight = 15

    Rows("8:8").RowHeight = 8

'Tamaño de fuente a datos generales

    Rows("9:13").Select

    With Selection.Font

        .Name = "Calibri"

        .Size = 10

    End With

    [B2] = "EMPRESA INVALIDA SA DE CV"

    [B3] = "RFC SACM831023CC0"

    [B4] = "AVENIDA 2 OTE NO 1159 COL CENTRO HUATUSCO VERACRUZ MEXICO"

    [B5] = "TELEFONO: 2731564470"

    [B6] = "EMAIL: marioni1023@hotmail.com"

    [C9] = "NOMBRE: LA ESPECIAL SA DE CV"

    [C10] = "DIRECCION: AV 5 PTE NO,152 COL CENTRO OAXACA OAX"

    [C11] = "FECHA Y HORA:23/10/2023-02:27:22 p.m."

    [C12] = "CONDICIONES DE PAGO:CONTADO"

    [C13] = "FORMA DE PAGO: TRASNSFERENCIA ELECTRONICA DE FONDOS"

    [F9] = "NOTA DE VENTA"

    [F10] = "SERIE Y FOLIO: A1000"

    [F11] = "REFERENCIA:O.C.1764"

    [F12] = "USUARIO:1.-admin"

    [F13] = "ESTATUS:VIGENTE"

    [C15] = "CODIGO"

    [D15] = "CANTID"

    [E15] = "DESCRIPCION"

    [F15] = "PRECIO"

    [G15] = "DESC"

    [H15] = "IMPORTE"

    Range("A1").Select

End Sub

Diseñar un formato tamaño tikets 8mm

Formato Tikets 8 mm

 Sub FormatoTikets8mm()
'Seleccionamos la hoja
With ActiveSheet.PageSetup
'Definimos encabezado izquierdo fecha y hora
    .LeftHeader = "&D-&T"
'Definimos margen superior
    .TopMargin = Application.InchesToPoints(0.433070866141732)
'Definimos margen inferior
    .BottomMargin = Application.InchesToPoints(0.118110236220472)
'Definimos margen izquierdo
    .LeftMargin = Application.InchesToPoints(0.118110236220472)
'Definimos margen derecho
    .RightMargin = Application.InchesToPoints(0.118110236220472)
'Definimos margen del encabezado
    .HeaderMargin = Application.InchesToPoints(0.196850393700787)
'Definimos margen del pie de página
    .FooterMargin = Application.InchesToPoints(0.31496062992126)
End With
'Definimos fuente y tamaño de la columna A
Columns("A:A").Select
With Selection.Font
    .Name = "Calibri"
    .Size = 9
End With
'Definimos ancho de la columna A en 8mm es 32.86
Columns("A:A").ColumnWidth = 32.86
With Selection
'Definimos alineación
    .HorizontalAlignment = xlGeneral
    .VerticalAlignment = xlCenter
    .WrapText = True
    .ReadingOrder = xlContext
End With
Range("A1").Select
With Selection
'Definimos alineación celda A1
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = True
    .ReadingOrder = xlContext
End With
'Cambiar tipo y tamaño de letra a toda la hoja
End Sub

Objetos Excel

 

Objetos propios de Excel.

• Cell: Hace referencia a la celdas.

[A1]="CLAVE"

[B1]="PRODUCTO"

[C1]="COSTO"

[D1]="PRECIO"

[E1]="STOCK"

[A2]="1000"

[B2]="AZUCAR"

[C2]="20.00"

[D2]="25.00"

[E2]="15.00" e.t.c.

Tomando el objeto Cell sería:

       Fila,Columna

Cells(1   ,    1)="CLAVE"

Cells(1,2)="PRODUCTO"

Cells(1,3)="COSTO"

Cells(1,4)="PRECIO"

Cells(1,5)="STOCK"

Cells(2,1)="1000"

Cells(2,2)="AZUCAR"

Cells(2,3)="20.00"

Cells(2,4)="25.00"

Cells(2,5)="15.00" e.t.c.

Otra forma:

Cells(1,"A").Value="CLAVE"

Cells(1,"B").Value="PRODUCTO"

Cells(1,"C").Value="COSTO"

Cells(1,"D").Value="PRECIO"

Cells(1,"E").Value="STOCK"

Cells(2,"A").Value="1000"

Cells(2,"B").Value="AZUCAR"

Cells(2,"C").Value="20.00"

Cells(2,"D").Value="25.00"

Cells(2,"E").Value="15.00" e.t.c.

• Range: Hace referencia a un rango de celdas.

Range("A1").Value="CLAVE"

Range("B1").Value="PRODUCTO"

Range("C1").Value="COSTO"

Range("D1").Value="PRECIO"

Range("E1").Value="STOCK"

Range("A3").Formula="=A1+A2"

Range("A3").Formula = "=SUM(A1:A2)"

Range("A1:H8").Formula="=Rand()" 'Aleatorio

• Sheets

Sheets("Hoja1").Cells(1, 1) = "CLAVE"

Sheets("Hoja1").Cells(1, 2) = "PRODUCTO"

Sheets("Hoja1").Cells(1, 3) = "COSTO"

Sheets(1).Cells(1, 4) = "PRECIO"

Sheets(1).Cells(1, 5) = "STOCK"

Sheets.Add , after:=Sheets(1) 'Insertar 1 hoja después de la hoja 1

• WorkSheets

Worksheets("Hoja1").Cells(1, 1) = "CLAVE"

Worksheets("Hoja1").Cells(1, 2) = "PRODUCTO"

Worksheets("Hoja1").Cells(1, 3) = "COSTO"

Worksheets(1).Cells(1, 4) = "PRECIO"

Worksheets(1).Cells(1, 5) = "STOCK"

• ThisWorkbook

ThisWorkbook.Worksheets("Hoja1").Range("A1") = "CLAVE"

For Each ws In Worksheets

    MsgBox ws.Name

Next ws

Plantilla PtoVta

Control de inventario mejorado.

1.-Articulos.

2.-Proveedores.

3.-Clientes.

4.-Compras,Cotizaciones,Tikets,Devolución de ventas,

5.-Ajustes de inventario.

6.-Mermas de inventario.

7.-Importaciones, exportaciones.

8.-Reporte de documentos.

9.-Formato tamaño tikets.

10.-Puede usar cajón de dinero y lector de código de barras (opcional)

10.-Búsqueda avanzada por fechas, clave, código, nombre e.t.c

11.-Permisos.

Emisión de documentos con o sin lector de código de barras

Información de stock bajo

Formato impresión 8 mm

Listado de documentos

Catálogo de artículos

Altas y modificaciones de artículos

Catálogo de proveedores

Altas y modificaciones de proveedores

Catálogo de clientes

Altas y modificaciones de clientes

Permisos de usuario

Ocultar hojas y contraseñas

El costo de la plantilla es de $ 500.00 pesos mexicanos. Incluye actualizaciones futuras.

Contáctame: +522731564470