Como pasar con enter datos seleccionados en listbox multiselect a hoja Excel





Un suscriptor pregunta como pasar varios datos seleccionados en un listbox multiselect cuando se presione enter, eso es lo que muestra este ejemplo que se presenta en el presente pos, quizás sea de utilidad lo que se enseñó anteriormente que es como pasar datos de un listbox a otro listbox con enter, como pasar datos de un listbox a otro listbox con doble click, como mostrar en un listbox una suma, cuenta y promedio.

El ejemplo que se puede descargar desde el link del final permite seleccionar varios ítemes de un listbox multiselect, luego al presionar enter se pasan todos los datos seleccionados en el listbox a la hoja de excel.

Antes de seguir recomiendo leer un excelente libro sobre Excel que te ayudará operar las planillas u hojas de cálculo, haz click acá, si quieres aprender sobre Excel, en inglés, entonces debes hacer click here. Si lo que necesitas es aprender o profundizar sobre la programación de macros con VBA este es unos de los mejores cursos on line que he visto en internet.


  

Un listbox multiselect a diferencia de un listbox que no es multiselect, permite seleccionar varios ítemes a la vez, es por ello que para pasar todos los datos a la hoja de Excel con Enter, se debe apelar a un bucle que recorra todas las filas del listbox determinando si está seleccionada en ese caso y solo en ese caso se pasan los datos requeridos a la hoja de Excel, para ello en este ejemplo el código que se aplica es el siguiente:

Private Sub ListBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
On Error Resume Next
If KeyAscii = 13 Then
For x = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(x) = True Then
Set a = Sheets("Hoja1")
filaedit = a.Range("A" & Rows.Count).End(xlUp).Row + 1
fila = Me.ListBox1.ListIndex
a.Cells(filaedit, "A") = ListBox1.List(x, 0)
a.Cells(filaedit, "B") = ListBox1.List(x, 1)
a.Cells(filaedit, "C") = ListBox1.List(x, 2)
a.Cells(filaedit, "D") = ListBox1.List(x, 3)
a.Cells(filaedit, "E") = ListBox1.List(x, 4)
a.Cells(filaedit, "F") = ListBox1.List(x, 5)
a.Cells(filaedit, "G") = ListBox1.List(x, 6)
a.Cells(filaedit, "H") = ListBox1.List(x, 7)
filaedit = filaedit + 1
End If
Next x
End If
End Sub

Si se observa el código, con KeyAscci=13 se detecta si se ha presionado enter, ya 13 es en código que se Asigna en Código Ascci a la tecla Enter, en caso que se haya presionado enter se procede a realizar un bucle desde la primera a la última fila del listbox, en ese recorrido determina si la fila está seleccionada, en caso positivo traslada los datos del listbox a Excel.

Para determinar si una linea o fila del listbox está seleccionada, se utiliza el siguiente código:

If Me.ListBox1.Selected(x) = True Then
....
End If

El código anterior es lo que permite filtrar todas las filas seleccionadas del listbox, es por ello que solo permite pasar a la hoja de Excel los datos seleccionados.

El vídeo que sigue muestra una explicación más detallada y gráfica de la macro presentada, recomiendo observar para una más fácil comprensión de la macro; suscribe a nuestra web desde la parte superior derecha de la página ingresando tu mail y a nuestro canal de You Tube para recibir en tu correo vídeos explicativos sobre macros interesantes, como  por ejemplo formulario que crea un listado de todas las hojas para poder luego seleccionarlasbuscar en listbox mientras escribes en textboxordenar hojas libro excel por su nombreconectar Excel con Access y muchos ejemplos más.







Código que se inserta en un módulo




Sub muestra()
UserForm1.Show
End Sub


Código que se inserta en un formulario

Private Sub CommandButton1_Click()
Unload Me
End Sub

Private Sub ListBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
On Error Resume Next
If KeyAscii = 13 Then
For x = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(x) = True Then
Set a = Sheets("Hoja1")
filaedit = a.Range("A" & Rows.Count).End(xlUp).Row + 1
fila = Me.ListBox1.ListIndex
a.Cells(filaedit, "A") = ListBox1.List(x, 0)
a.Cells(filaedit, "B") = ListBox1.List(x, 1)
a.Cells(filaedit, "C") = ListBox1.List(x, 2)
a.Cells(filaedit, "D") = ListBox1.List(x, 3)
a.Cells(filaedit, "E") = ListBox1.List(x, 4)
a.Cells(filaedit, "F") = ListBox1.List(x, 5)
a.Cells(filaedit, "G") = ListBox1.List(x, 6)
a.Cells(filaedit, "H") = ListBox1.List(x, 7)
filaedit = filaedit + 1
End If
Next x
End If
End Sub



Private Sub CommandButton2_Click()
Dim conta As Integer
On Error Resume Next
conta = 0
For x = 0 To Me.ListBox1.ListCount - 1
    If Me.ListBox1.Selected(x) = True Then
    conta = conta + 1
    End If
Next x
If conta = 0 Then
MsgBox "Debe seleccionar un item para copiar en hoja de Excel", vbInformation, "AVISO"
Exit Sub
End If
conta = 0
Set a = Sheets("Hoja1")
filaedit = a.Range("A" & Rows.Count).End(xlUp).Row + 1
For x = 0 To Me.ListBox1.ListCount - 1
    If Me.ListBox1.Selected(x) = True Then
    conta = conta + 1
    End If
Next x
If conta <> 0 Then
For x = 0 To Me.ListBox1.ListCount - 1
          If Me.ListBox1.Selected(x) = True Then
            'fila = Me.ListBox1.ListIndex.SelectedItem
            a.Cells(filaedit, "A") = ListBox1.List(x, 0)
            a.Cells(filaedit, "B") = ListBox1.List(x, 1)
            a.Cells(filaedit, "C") = ListBox1.List(x, 2)
            a.Cells(filaedit, "D") = ListBox1.List(x, 3)
            a.Cells(filaedit, "E") = ListBox1.List(x, 4)
            a.Cells(filaedit, "F") = ListBox1.List(x, 5)
            a.Cells(filaedit, "G") = ListBox1.List(x, 6)
            a.Cells(filaedit, "H") = ListBox1.List(x, 7)
            Me.ListBox1.Selected(x) = False
            filaedit = filaedit + 1
          End If
Next x
End If
End Sub
Private Sub ListBox1_Change()
TextBox3 = Clear
For x = 0 To Me.ListBox1.ListCount - 1
    If Me.ListBox1.Selected(x) = True Then
    tot = tot + CDec(UserForm1.ListBox1.List(x, 7))
    End If
Next x
TextBox3.Text = Format(tot, "Currency")
TextBox3.TextAlign = fmTextAlignRight
End Sub

Private Sub TextBox1_Change()
On Error Resume Next
TextBox3 = Clear
Set b = Sheets("Hoja2")
uf = b.Range("A" & Rows.Count).End(xlUp).Row
If Trim(TextBox1.Value) = "" Then
     'Me.ListBox1.List() = b.Range("A2:H" & uf).Value
     Me.ListBox1.RowSource = "Hoja2!A2:H" & uf
   Exit Sub
End If
b.AutoFilterMode = False
Me.ListBox1 = Clear
Me.ListBox1.RowSource = Clear
For i = 2 To uf
   strg = b.Cells(i, 3).Value
   If UCase(strg) Like UCase(TextBox1.Value) & "*" Then
       Me.ListBox1.AddItem b.Cells(i, 1)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = b.Cells(i, 2)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2) = b.Cells(i, 3)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 3) = b.Cells(i, 4)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 4) = b.Cells(i, 5)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 5) = b.Cells(i, 6)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 6) = b.Cells(i, 7)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 7) = b.Cells(i, 8)
   End If
Next i
Me.ListBox1.ColumnWidths = "20 pt;70 pt;180 pt;80 pt;60 pt;60 pt;60 pt;60pt"
End Sub
Private Sub TextBox2_Change()
On Error Resume Next
TextBox3 = Clear
Set b = Sheets("Hoja2")
uf = b.Range("A" & Rows.Count).End(xlUp).Row
If Trim(TextBox2.Value) = "" Then
     'Me.ListBox1.List() = b.Range("A2:H" & uf).Value
     Me.ListBox1.RowSource = "Hoja2!A2:H" & uf
   Exit Sub
End If
b.AutoFilterMode = False
Me.ListBox1 = Clear
Me.ListBox1.RowSource = Clear
For i = 2 To uf
   strg = b.Cells(i, 4).Value
   If UCase(strg) Like UCase(TextBox2.Value) & "*" Then
       Me.ListBox1.AddItem b.Cells(i, 1)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = b.Cells(i, 2)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2) = b.Cells(i, 3)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 3) = b.Cells(i, 4)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 4) = b.Cells(i, 5)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 5) = b.Cells(i, 6)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 6) = b.Cells(i, 7)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 7) = b.Cells(i, 8)
   End If
Next i
Me.ListBox1.ColumnWidths = "20 pt;70 pt;180 pt;80 pt;60 pt;60 pt;60 pt;60pt"
End Sub


Private Sub UserForm_Initialize()
Dim fila As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set b = Sheets("Hoja2")
uf = b.Range("A" & Rows.Count).End(xlUp).Row
uc = b.Cells(1, Columns.Count).End(xlToLeft).Address
wc = Mid(uc, InStr(uc, "$") + 1, InStr(2, uc, "$") - 2)
With Me.ListBox1
    .ColumnCount = 8
    .ColumnWidths = "20 pt;70 pt;180 pt;80 pt;60 pt;60 pt;60 pt;60pt"
    .RowSource = "Hoja2!A2:" & wc & uf
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error GoTo Fin
If CloseMode <> 1 Then Cancel = True
Fin:
End Sub



Si te fue de utilidad puedes INVITARME UN CAFÉ y de esta manera ayudar a seguir manteniendo la página, CLICK para descargar en ejemplo en forma gratuita.


If this post was helpful INVITE ME A COFFEE and so help keep up the page, CLICK to download free example.


Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends      

Como abrir dos libros copiar datos de uno a otro y guardar en otro libro





A pedido de un suscriptor de nuestro canal de You Tube, presentamos este ejemplo de macro que permite abrir dos archivos copiar datos del primero fichero al segundo y luego hacer una copia del segundo libro guardando como en el escritorio de Windows, anteriormente se presentaron ejemplos relacionados que quizás te interesen: macro hace una copia de la hoja activa y la guarda como; macro hace una copia de la hoja y la guarda como utilizando explorador de archivos de Windows, macro que permite copiar varias hojas y las guarda como, macro que copia varias hojas y las guarda como con el explorador de archivos de Windows.

Antes de seguir recomiendo leer un excelente libro sobre Excel que te ayudará operar las planillas u hojas de cálculo, haz click acá, si quieres aprender sobre Excel, en inglés, entonces debes hacer click here. Si lo que necesitas es aprender o profundizar sobre la programación de macros con VBA este es unos de los mejores cursos on line que he visto en internet.


  

Desde el final podrás descargar el archivo comprimido que contiene el archivo con la macro y dos archivos que utiliza como origen y destino para copiar datos, recuerda copiar descomprimir los archivos y guardarlo en cualquier parte de la PC con la condición que estén los tres ficheros juntos en el directorio en el cual se guardaron.

Este ejemplo de macro abre un archivo que contiene datos que se desean pasar al archivo de destino, por ello la macro abre los dos archivos pasando datos desde el archivo de origen al de destino, luego cierra ambos libros sin guardar cambios, pero previamente hace una copia de la hoja del libro destino donde se copiaron los datos y este nuevo libro lo guarda en el escritorio con el nombre que previamente se definió en la macro.

El copiado de datos desde el origen al destino, no es un simple copie y pegue, copia datos, pero en filas que no son las mismas en el origen que en el destino, a su vez las columnas están intercambiadas es decir la columna C la copia en la columna F del destino y así sucesivamente con otras columnas.

En este ejemplo de macro que permite abrir dos libros copiar datos de uno a otro y luego guardar una copia en el escritorio de Windows con otro nombre, se muestra como crear una ruta de un archivo o fichero  con variables de la siguiente forma:

ruta = ActiveWorkbook.Path
myfile1 = ruta & "\334 REPORTE ORIGEN.xlsx"

Abrir un archivo de Excel con el siguiente código y guardar su nombre en una variable:

Workbooks.Open Filename:=myfile1, UpdateLinks:=0
FullName = Split(myfile1, Application.PathSeparator)
WBO = FullName(UBound(FullName))

Como determinar la última fila con datos cuando en la estructura del archivo hay datos que no interesan copiar y obstaculizan encontrar la última fila con datos:

uf = Workbooks(WBO).Sheets(b1).Range("A" & Rows.Count).End(xlUp).End(xlUp).End(xlUp).End(xlUp).End(xlUp).Row - 1

Como copiar mediante bucle hasta la última fila con datos, información de un libro a otro no siendo consecutivos, es decir los datos de las columnas del libro origen copiarlos en columnas distintas del libro destino, de la siguiente forma

For x = 8 To uf
Workbooks(WBO).Sheets(b1).Cells(x, "A").Copy Destination:=Workbooks(WBD).Sheets(b2).Cells(j, "A")
Next x


Como cerrar un libro sin guardar cambios y guardando cambios.

Workbooks(WBD).Close False
ActiveWorkbook.Close True

El vídeo que sigue muestra una explicación más detallada y gráfica de la macro presentada, recomiendo observar para una más fácil comprensión de la macro; suscribe a nuestra web desde la parte superior derecha de la página ingresando tu mail y a nuestro canal de You Tube para recibir en tu correo vídeos explicativos sobre macros interesantes, como  por ejemplo Como crear una factura o sale invoice y grabar guardar PDF XLS y enviar por mailbuscar en listbox mientras escribes en textboxordenar hojas libro excel por su nombreconectar Excel con Access y muchos ejemplos más.









Código que se inserta en un módulo




Sub openbook()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Dim myfile1, myfile2, myfile3, mydesk, WBO, WBD, b1, b2

ruta = ActiveWorkbook.Path
myfile1 = ruta & "\334 REPORTE ORIGEN.xlsx"
myfile2 = ruta & "\334 REPORTE DESTINO.xlsx"
mydesk = CreateObject("wscript.shell").specialfolders("desktop")
myfile3 = mydesk & "\334 REPORTE COPIA.xlsx"

Workbooks.Open Filename:=myfile1, UpdateLinks:=0
FullName = Split(myfile1, Application.PathSeparator)
WBO = FullName(UBound(FullName))
b1 = ActiveSheet.Name

Workbooks.Open Filename:=myfile2, UpdateLinks:=0
FullName = Split(myfile2, Application.PathSeparator)
WBD = FullName(UBound(FullName))
b2 = ActiveSheet.Name

Workbooks(WBO).Activate
uf = Workbooks(WBO).Sheets(b1).Range("A" & Rows.Count).End(xlUp).End(xlUp).End(xlUp).End(xlUp).End(xlUp).Row - 1
j = 6
For x = 8 To uf
Workbooks(WBO).Sheets(b1).Cells(x, "A").Copy Destination:=Workbooks(WBD).Sheets(b2).Cells(j, "A")
Workbooks(WBO).Sheets(b1).Cells(x, "C").Copy Destination:=Workbooks(WBD).Sheets(b2).Cells(j, "D")
Workbooks(WBO).Sheets(b1).Cells(x, "F").Copy Destination:=Workbooks(WBD).Sheets(b2).Cells(j, "C")
Workbooks(WBO).Sheets(b1).Cells(x, "H").Copy Destination:=Workbooks(WBD).Sheets(b2).Cells(j, "F")
j = j + 1
Next x
Workbooks(WBO).Close False

Workbooks(WBD).Activate
ActiveSheet.Copy
ActiveWorkbook.SaveAs Filename:=myfile3, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close True
Workbooks(WBD).Close False

MsgBox ("El archivo se guardó con éxito en " & myfile3), vbInformation, "AVISO"
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub



Si te fue de utilidad puedes INVITARME UN CAFÉ y de esta manera ayudar a seguir manteniendo la página, CLICK para descargar en ejemplo en forma gratuita.


If this post was helpful INVITE ME A COFFEE and so help keep up the page, CLICK to download free example.


Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends      

Como cargar en combobox de userform cabeceras o header de columnas





Anteriormente se vió como cargar las cabeceras o header de las columnas en un combobox incrustado en Excel en este post presento una variante que es como cargar las cabeceras o header en un combobox, pero de un Userform de VBA o Formulario de Excel.

Desde el link del final se podrá descargar este ejemplo, cada uno le encontrará la utilidad, pero creo que es útil cuando se tiene que buscar datos y es necesario dar la opción al operador del sistema que seleccione la columna por la cual desea filtrar los datos, entonces tener cargado en un comobox los campos evita que el usuario escriba el nombre del campo por el que desea buscar y de esta forma se puede evitar errores de escritura y por ende pérdida de tiempo, ademas que se exponen cuales son los campos por los cuales se puede buscar.

Antes de seguir recomiendo leer un excelente libro sobre Excel que te ayudará operar las planillas u hojas de cálculo, haz click acá, si quieres aprender sobre Excel, en inglés, entonces debes hacer click here. Si lo que necesitas es aprender o profundizar sobre la programación de macros con VBA este es unos de los mejores cursos on line que he visto en internet.


  

El código es muy sencillo, no por ello útil, muestra como se usa la estructura For Each, la cual recorre cada una de las celdas en un rango de datos establecidos en este caso, es donde están los datos de las cabeceras o header de las columnas, el código en forma resumida es el siguiente:

For Each celda In Sheets("Hoja1").Range("A1:I1")
ComboBox1.AddItem celda
Next celda

Debajo se encuentra el código completo que se debe pegar en userform, el eventos que permite cargar los datos es al hacer click en la fecha del combobox o más técnicamente en el evento DropButtonClick; no obstante lo dicho recomiendo si no se tiene mucho conocimiento en el tema descargar el archivo y ver el funcionamiento del ejemplo denominado como cargar en combobox de userform cabeceras o header de columnas.

El vídeo que sigue muestra una explicación más detallada y gráfica de la macro presentada, recomiendo observar para una más fácil comprensión de la macro; suscribe a nuestra web desde la parte superior derecha de la página ingresando tu mail y a nuestro canal de You Tube para recibir en tu correo vídeos explicativos sobre macros interesantes, como  por ejemplo Las 1000 mejores macros de Excelbuscar en listbox mientras escribes en textbox, como copiar tablas vinculadas de Excel a Wordconectar Excel con Access y muchos ejemplos más.










Código que se inserta en un módulo




Sub muestra()
UserForm1.Show
End Sub


Código que se inserta en un formulario

Private Sub ComboBox1_DropButtonClick()
Application.ScreenUpdating = False
Dim celda
On Error Resume Next
Sheets("Hoja1").ComboBox1.Clear
For Each celda In Sheets("Hoja1").Range("A1:I1")
ComboBox1.AddItem celda
Next celda
Application.ScreenUpdating = False
End Sub



Si te fue de utilidad puedes INVITARME UN CAFÉ y de esta manera ayudar a seguir manteniendo la página, CLICK para descargar en ejemplo en forma gratuita.


If this post was helpful INVITE ME A COFFEE and so help keep up the page, CLICK to download free example.


Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends      

Como crear una factura o sale invoice y descontar de Stock o Inventario





En este post se muestra como crear una factura o sale invoice y descontar del Stock o Inventario los productos vendidos, esto fue un agregado por el pedido de un suscriptor, lo cual me pareció interesante y que podría servir de ejemplo a varios lectores, si alguno necesita una variante o que se agregue algo más en los ejemplos, es cuestión que lo propongan y si es útil a muchos lectores, realizo un ejemplo con ello; así que suscriban (YouTube, Suscribir a Web) para no perderse los ejemplos posteriores seguramente serán de utilidad o por lo menos dará alguna idea sobre como encarar una automatización de hojas de Excel o proyectos de VB.

El link de los post relacionados directamente con la creación de una Factura de Venta en Excel, seguidamente se listan.

Como crear una factura o sale invoice seleccionando cliente de listbox
Como crear una factura o sale invoice guardar cliente nuevo
Como crear una factura o sale invoice seleccionando articulos en listbox
Como crear una factura o sale invoice eliminar articulos del listbox
Como crear una factura o sale invoice y guardar registro
Como crear una factura o sale invoice guardar e imprimir
Como crear una factura o sale invoice y guardar en PDF
Como crear una factura o sale invoice y grabar guardar PDF XLS y enviar por MAIL
Como crear una factura o sale invoice y descontar de Stock o Inventario

Antes de seguir recomiendo leer un excelente libro sobre Excel que te ayudará operar las planillas u hojas de cálculo, haz click acá, si quieres aprender sobre Excel, en inglés, entonces debes hacer click here. Si lo que necesitas es aprender o profundizar sobre la programación de macros con VBA este es unos de los mejores cursos on line que he visto en internet.


  

Algo bastante importante al momento de facturar un producto es que el modulo de facturación se encuentre relacionado con la base de datos de los artículos y proceda a descontar del stock o inventario con el objeto de saber en cualquier momento con que cantidad de artículos hay en existencia y en que momento es necesario volver a comprar a los proveedores para mantener el stock o nivel de inventario, también es útil si se desea mantener un control del inventario.

En este ejemplo al momento de seleccionar el producto a facturar, se descuenta del stock, si se facturó por error algún producto, al realizar doble click sobre el listbox del formulario de venta se elimina del listbox, pero automáticamente se suma el stock que se restó y no se facturó.

Al momento de seleccionar en el textbox se determina el stock del producto, buscando el código del producto en la hoja Artículos, una vez encontrado el código se guarda en una variable publica la fila donde se encuentra el producto; con el siguiente código

Set codigo = a.Range("B2:B" & filaedit).Find(cod, LookIn:=xlValues, LookAt:=xlWhole)
If Not codigo Is Nothing Then
stodir = codigo.Row
End If

Posteriormente cuando se ingresa la cantidad a facturar, se resta el stock actual menos la cantidad que se facturó, para ello se toma de la hoja Artículos el stock que hay en la fila y columna correspondiente y se le resta la cantidad cargada en el textbox al momento de facturar.

stoold = a1.Cells(stodir, "G")
a1.Cells(stodir, "G") = a1.Cells(stodir, "G") - can

Cuando se anula o elimina un ítem del listbox, automáticamente se suma al stock actual la cantidad restada por error, desde el link del final se puede descargar el ejemplo de macro que permite crear una factura o sale invoice y descontar del stock.

El vídeo a continuación muestra como trabaja la macro; suscribe a nuestra web desde la parte superior derecha de la página ingresando tu mail y a nuestro canal de You Tube para recibir en tu correo vídeos explicativos sobre macros interesantes, como  por ejemplo como mostar en listbox suma cuenta y promediobuscar en listbox mientras escribes en textbox, como enviar mail en el cuerpo del mensaje con PDF adjuntoconectar Excel con Access, como rellenar un pagaré conectando Excel con Word y muchos ejemplos más.










Código que se inserta en un módulo




Public cod, art, mar, pv, ctr, creg, stodir As Long, can As Long
Sub muestra1()
UserForm2.Show
End Sub



Código que se inserta en un formulario

Private Sub CommandButton1_Click()
Unload Me
End Sub

Private Sub ListBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
On Error Resume Next
If KeyAscii = 13 Then
Set a = Sheets("Articulos")
filaedit = a.Range("A" & Rows.Count).End(xlUp).Row
fila = Me.ListBox1.ListIndex
'a.Cells(filaedit, "A") = ListBox1.List(fila, 0)
'a.Cells(filaedit, "B") = ListBox1.List(fila, 1)
'a.Cells(filaedit, "C") = ListBox1.List(fila, 2)
'a.Cells(filaedit, "D") = ListBox1.List(fila, 3)
'a.Cells(filaedit, "E") = ListBox1.List(fila, 4)
'a.Cells(filaedit, "F") = ListBox1.List(fila, 5)
'a.Cells(filaedit, "G") = ListBox1.List(fila, 6)
'a.Cells(filaedit, "H") = ListBox1.List(fila, 7)
'a.Cells(filaedit, "I") = ListBox1.List(fila, 8)
cod = ListBox1.List(fila, 1)
art = ListBox1.List(fila, 2)
mar = ListBox1.List(fila, 3)
pv = ListBox1.List(fila, 8)

Set codigo = a.Range("B2:B" & filaedit).Find(cod, LookIn:=xlValues, LookAt:=xlWhole)
If Not codigo Is Nothing Then
stodir = codigo.Row
End If

End If
Unload UserForm1
UserForm3.Show
End Sub

Private Sub TextBox1_Change()
On Error Resume Next
Set b = Sheets("Articulos")
uf = b.Range("A" & Rows.Count).End(xlUp).Row
If Trim(TextBox1.Value) = "" Then
Me.ListBox1.Clear
     'Me.ListBox1.List() = b.Range("A2:H" & uf).Value
     'Me.ListBox1.RowSource = "Hoja2!A2:H" & uf
     'Adiciona un item al listbox reservado para la cabecera
UserForm1.ListBox1.AddItem

For i = 2 To uf
  ' strg = b.Cells(i, 4).Value
   'If UCase(strg) Like UCase(TextBox2.Value) & "*" Then
       Me.ListBox1.AddItem b.Cells(i, 1)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = b.Cells(i, 2)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2) = b.Cells(i, 3)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 3) = b.Cells(i, 4)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 4) = b.Cells(i, 5)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 5) = b.Cells(i, 6)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 6) = b.Cells(i, 7)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 7) = b.Cells(i, 8)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 8) = b.Cells(i, 9)
  ' End If
Next i

'Carga los datos de la cabecera en listbox
For ii = 0 To 9
UserForm1.ListBox1.List(0, ii) = Sheets("Articulos").Cells(1, ii + 1)
Next ii
   Exit Sub
End If

b.AutoFilterMode = False
Me.ListBox1.Clear
Me.ListBox1.RowSource = Clear
'Adiciona un item al listbox reservado para la cabecera
UserForm1.ListBox1.AddItem
For i = 2 To uf
   strg = b.Cells(i, 3).Value
   If UCase(strg) Like UCase(TextBox1.Value) & "*" Then
       Me.ListBox1.AddItem b.Cells(i, 1)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = b.Cells(i, 2)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2) = b.Cells(i, 3)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 3) = b.Cells(i, 4)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 4) = b.Cells(i, 5)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 5) = b.Cells(i, 6)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 6) = b.Cells(i, 7)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 7) = b.Cells(i, 8)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 8) = b.Cells(i, 9)
   End If
Next i

'Carga los datos de la cabecera en listbox
For ii = 0 To 9
UserForm1.ListBox1.List(0, ii) = Sheets("Articulos").Cells(1, ii + 1)
Next ii
'Me.ListBox1.ColumnWidths = "20 pt;70 pt;180 pt;80 pt;60 pt;60 pt;60 pt;60pt"
End Sub
Private Sub TextBox2_Change()
On Error Resume Next
Set b = Sheets("Articulos")
uf = b.Range("A" & Rows.Count).End(xlUp).Row
If Trim(TextBox2.Value) = "" Then
Me.ListBox1.Clear
     'Me.ListBox1.List() = b.Range("A2:H" & uf).Value
     'Me.ListBox1.RowSource = "Hoja2!A2:H" & uf
     'Adiciona un item al listbox reservado para la cabecera
UserForm1.ListBox1.AddItem

For i = 2 To uf
  ' strg = b.Cells(i, 4).Value
   'If UCase(strg) Like UCase(TextBox2.Value) & "*" Then
       Me.ListBox1.AddItem b.Cells(i, 1)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = b.Cells(i, 2)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2) = b.Cells(i, 3)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 3) = b.Cells(i, 4)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 4) = b.Cells(i, 5)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 5) = b.Cells(i, 6)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 6) = b.Cells(i, 7)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 7) = b.Cells(i, 8)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 8) = b.Cells(i, 9)
  ' End If
Next i

'Carga los datos de la cabecera en listbox
For ii = 0 To 9
UserForm1.ListBox1.List(0, ii) = Sheets("Articulos").Cells(1, ii + 1)
Next ii
   Exit Sub
End If
b.AutoFilterMode = False
Me.ListBox1.Clear
Me.ListBox1.RowSource = Clear

'Adiciona un item al listbox reservado para la cabecera
UserForm1.ListBox1.AddItem

For i = 2 To uf
   strg = b.Cells(i, 4).Value
   If UCase(strg) Like UCase(TextBox2.Value) & "*" Then
       Me.ListBox1.AddItem b.Cells(i, 1)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = b.Cells(i, 2)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2) = b.Cells(i, 3)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 3) = b.Cells(i, 4)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 4) = b.Cells(i, 5)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 5) = b.Cells(i, 6)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 6) = b.Cells(i, 7)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 7) = b.Cells(i, 8)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 8) = b.Cells(i, 9)
   End If
Next i

'Carga los datos de la cabecera en listbox
For ii = 0 To 9
UserForm1.ListBox1.List(0, ii) = Sheets("Articulos").Cells(1, ii + 1)
Next ii
End Sub

Private Sub UserForm_Initialize()
Dim fila As Long
On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set b = Sheets("Articulos")
uf = b.Range("A" & Rows.Count).End(xlUp).Row
uc = b.Cells(1, Columns.Count).End(xlToLeft).Address
wc = Mid(uc, InStr(uc, "$") + 1, InStr(2, uc, "$") - 2)
With Me.ListBox1
    .ColumnCount = 9
    .ColumnWidths = "20 pt;70 pt;180 pt;80 pt;60 pt;60 pt;60 pt;60pt;60pt"
    '.RowSource = "Hoja2!A1:" & wc & uf
End With
'Adiciona un item al listbox reservado para la cabecera
UserForm1.ListBox1.AddItem

For i = 2 To uf
  ' strg = b.Cells(i, 4).Value
   'If UCase(strg) Like UCase(TextBox2.Value) & "*" Then
       Me.ListBox1.AddItem b.Cells(i, 1)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = b.Cells(i, 2)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2) = b.Cells(i, 3)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 3) = b.Cells(i, 4)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 4) = b.Cells(i, 5)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 5) = b.Cells(i, 6)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 6) = b.Cells(i, 7)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 7) = b.Cells(i, 8)
       Me.ListBox1.List(Me.ListBox1.ListCount - 1, 8) = b.Cells(i, 9)
  ' End If
Next i

'Carga los datos de la cabecera en listbox
For ii = 0 To 9
UserForm1.ListBox1.List(0, ii) = Sheets("Articulos").Cells(1, ii + 1)
Next ii

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error GoTo Fin
If CloseMode <> 1 Then Cancel = True
Fin:
End Sub



Código que se inserta en un formulario

Private Sub CommandButton1_Click()
Dim verexi As Object, rutapdf As String, rutaxls As String, rutadir As String, nomfic As String
On Error Resume Next
Application.ScreenUpdating = False
If UserForm2.ListBox1.ListCount = 0 Or TextBox1 = Empty Or TextBox3 = Empty Then
MsgBox "Debe llenar fecha, cliente y seleccionar por lo menos un articulo antes de guardar en la base de datos", vbCritical, "AVISO"
Exit Sub
End If
Set a = Sheets("DbFac")
uf = a.Range("A" & Rows.Count).End(xlUp).Row + 1
For x = 0 To UserForm2.ListBox1.ListCount - 1
a.Cells(uf, "A") = Val(UserForm2.Label2.Caption)
a.Cells(uf, "B") = UserForm2.TextBox3
a.Cells(uf, "C") = UserForm2.Label3.Caption
a.Cells(uf, "D") = UserForm2.TextBox1
a.Cells(uf, "E") = UserForm2.TextBox2
a.Cells(uf, "F") = UserForm2.ListBox1.List(x, 0)
a.Cells(uf, "G") = UserForm2.ListBox1.List(x, 1)
a.Cells(uf, "H") = UserForm2.ListBox1.List(x, 2)
a.Cells(uf, "I") = CDec(UserForm2.ListBox1.List(x, 3))
a.Cells(uf, "J") = CDec(ListBox1.List(x, 5))
uf = uf + 1
Next x


Set b = Sheets("Factura")
b.Range("A9:I24").ClearContents
b.Range("H2") = UserForm2.Label2
b.Range("H3") = UserForm2.TextBox3
b.Range("B6") = UserForm2.TextBox1
b.Range("G6") = UserForm2.TextBox2
fila = 9
For x = 0 To UserForm2.ListBox1.ListCount - 1
b.Cells(fila, "A") = UserForm2.ListBox1.List(x, 0)
b.Cells(fila, "B") = UserForm2.ListBox1.List(x, 1)
b.Cells(fila, "E") = UserForm2.ListBox1.List(x, 2)
b.Cells(fila, "F") = CDec(UserForm2.ListBox1.List(x, 3))
b.Cells(fila, "G") = CDec(ListBox1.List(x, 4))
b.Cells(fila, "H") = b.Cells(fila, "F") * 0.16
b.Cells(fila, "I") = (b.Cells(fila, "F") * b.Cells(fila, "G")) * 1.16
fila = fila + 1
Next x




Application.PrintCommunication = True
Sheets("Factura").Activate
Sheets("Factura").Range("E60,G60,I60").NumberFormat = "#,##0.00 ""U$S"""
With ActiveSheet.PageSetup
.PrintArea = "$A$1:$I$60"
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Application.PrintCommunication = True

nomfic = UserForm2.Label2 & UserForm2.TextBox3 & UserForm2.TextBox1
nomfic = Replace(nomfic, "/", "")
rutadir = ActiveWorkbook.Path & "\Comprobantes VTA"
rutapdf = rutadir & "\" & nomfic & ".pdf"
rutaxls = rutadir & "\" & nomfic & ".xlsx"

'Verifica que la carpeta exista
If Dir(rutadir, vbDirectory) = "" Then
MkDir rutadir
End If

'Verfica si existe el archivo
Set verexi = CreateObject("Scripting.FileSystemObject")
If verexi.FileExists(rutadir) Then
MsgBox ("El comprobante de venta ya fue registrado"), vbInformation, "AVISO"
Exit Sub
Else
ActiveSheet.Copy
ActiveWorkbook.SaveAs Filename:=rutaxls, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close True
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=rutapdf, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=True, OpenAfterPublish:=False
End If

ActiveSheet.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False

Sheets("DbFac").Select
UserForm2.TextBox1 = Clear
UserForm2.TextBox2 = Clear
UserForm2.TextBox3 = Clear
UserForm2.ListBox1.Clear
UserForm2.Label14 = Clear
UserForm2.Label15 = Clear
UserForm2.Label16 = Clear
uf = Sheets("DbFac").Range("A" & Rows.Count).End(xlUp).Row
Nfac = Application.WorksheetFunction.Max(Sheets("DbFac").Range("A2" & ":A" & uf + 1)) + 1
Label2.Caption = Format(Nfac, "00000000")
MsgBox "El comprobante de venta se grabó en la base de datos y se guardo en PDF y XLSX", vbCritical, "AVISO"
Application.ScreenUpdating = True
End Sub

Private Sub CommandButton2_Click()
On Error Resume Next
If UserForm2.ListBox1.ListCount = 0 Or TextBox1 = Empty Or TextBox3 = Empty Then
MsgBox "Debe llenar fecha, cliente y seleccionar por lo menos un articulo antes de guardar en la base de datos", vbCritical, "AVISO"
Exit Sub
End If
Set a = Sheets("DbFac")
uf = a.Range("A" & Rows.Count).End(xlUp).Row + 1
For x = 0 To UserForm2.ListBox1.ListCount - 1
a.Cells(uf, "A") = Val(UserForm2.Label2.Caption)
a.Cells(uf, "B") = UserForm2.TextBox3
a.Cells(uf, "C") = UserForm2.Label3.Caption
a.Cells(uf, "D") = UserForm2.TextBox1
a.Cells(uf, "E") = UserForm2.TextBox2
a.Cells(uf, "F") = UserForm2.ListBox1.List(x, 0)
a.Cells(uf, "G") = UserForm2.ListBox1.List(x, 1)
a.Cells(uf, "H") = UserForm2.ListBox1.List(x, 2)
a.Cells(uf, "I") = CDec(UserForm2.ListBox1.List(x, 3))
a.Cells(uf, "J") = CDec(ListBox1.List(x, 5))
uf = uf + 1
Next x

UserForm2.TextBox1 = Clear
UserForm2.TextBox2 = Clear
UserForm2.TextBox3 = Clear
UserForm2.ListBox1.Clear
UserForm2.Label14 = Clear
UserForm2.Label15 = Clear
UserForm2.Label16 = Clear
uf = Sheets("DbFac").Range("A" & Rows.Count).End(xlUp).Row
Nfac = Application.WorksheetFunction.Max(Sheets("DbFac").Range("A2" & ":A" & uf + 1)) + 1
Label2.Caption = Format(Nfac, "00000000")
End Sub

Private Sub CommandButton3_Click()
UserForm1.Show
End Sub

Private Sub CommandButton4_Click()
Application.ScreenUpdating = True
On Error Resume Next
If UserForm2.ListBox1.ListCount = 0 Or TextBox1 = Empty Or TextBox3 = Empty Then
MsgBox "Debe llenar fecha, cliente y seleccionar por lo menos un articulo antes de guardar en la base de datos", vbCritical, "AVISO"
Exit Sub
End If
Set a = Sheets("DbFac")
uf = a.Range("A" & Rows.Count).End(xlUp).Row + 1
For x = 0 To UserForm2.ListBox1.ListCount - 1
a.Cells(uf, "A") = Val(UserForm2.Label2.Caption)
a.Cells(uf, "B") = UserForm2.TextBox3
a.Cells(uf, "C") = UserForm2.Label3.Caption
a.Cells(uf, "D") = UserForm2.TextBox1
a.Cells(uf, "E") = UserForm2.TextBox2
a.Cells(uf, "F") = UserForm2.ListBox1.List(x, 0)
a.Cells(uf, "G") = UserForm2.ListBox1.List(x, 1)
a.Cells(uf, "H") = UserForm2.ListBox1.List(x, 2)
a.Cells(uf, "I") = CDec(UserForm2.ListBox1.List(x, 3))
a.Cells(uf, "J") = CDec(ListBox1.List(x, 5))
uf = uf + 1
Next x


Set b = Sheets("Factura")
b.Range("A9:I24").ClearContents
b.Range("H2") = UserForm2.Label2
b.Range("H3") = UserForm2.TextBox3
b.Range("B6") = UserForm2.TextBox1
b.Range("G6") = UserForm2.TextBox2
fila = 9
For x = 0 To UserForm2.ListBox1.ListCount - 1
b.Cells(fila, "A") = UserForm2.ListBox1.List(x, 0)
b.Cells(fila, "B") = UserForm2.ListBox1.List(x, 1)
b.Cells(fila, "E") = UserForm2.ListBox1.List(x, 2)
b.Cells(fila, "F") = CDec(UserForm2.ListBox1.List(x, 3))
b.Cells(fila, "G") = CDec(ListBox1.List(x, 4))
b.Cells(fila, "H") = b.Cells(fila, "F") * 0.16
b.Cells(fila, "I") = (b.Cells(fila, "F") * b.Cells(fila, "G")) * 1.16
fila = fila + 1
Next x


UserForm2.TextBox1 = Clear
UserForm2.TextBox2 = Clear
UserForm2.TextBox3 = Clear
UserForm2.ListBox1.Clear
UserForm2.Label14 = Clear
UserForm2.Label15 = Clear
UserForm2.Label16 = Clear

uf = Sheets("DbFac").Range("A" & Rows.Count).End(xlUp).Row
Nfac = Application.WorksheetFunction.Max(Sheets("DbFac").Range("A2" & ":A" & uf + 1)) + 1
Label2.Caption = Format(Nfac, "00000000")

Application.PrintCommunication = True
Sheets("Factura").Activate

Sheets("Factura").Range("E60,G60,I60").NumberFormat = "#,##0.00 ""U$S"""
With ActiveSheet.PageSetup
.PrintArea = "$A$1:$I$60"
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Application.PrintCommunication = True
ActiveSheet.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
Sheets("DbFac").Select
MsgBox "El comprobante de venta se guardo e imprimió con éxito", vbCritical, "AVISO"
Application.ScreenUpdating = True
End Sub

Private Sub CommandButton5_Click()
Dim a As Worksheet, b As Worksheet
Dim OApp As Object, OMail As Object, sbdy As String
Dim verexi As Object, rutapdf As String, rutaxls As String, rutadir As String, nomfic As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next

If UserForm2.ListBox1.ListCount = 0 Or TextBox1 = Empty Or TextBox3 = Empty Then
MsgBox "Debe llenar fecha, cliente y seleccionar por lo menos un articulo antes de guardar en la base de datos", vbCritical, "AVISO"
Exit Sub
End If
Set a = Sheets("DbFac")
uf = a.Range("A" & Rows.Count).End(xlUp).Row + 1
For x = 0 To UserForm2.ListBox1.ListCount - 1
a.Cells(uf, "A") = Val(UserForm2.Label2.Caption)
a.Cells(uf, "B") = UserForm2.TextBox3
a.Cells(uf, "C") = UserForm2.Label3.Caption
a.Cells(uf, "D") = UserForm2.TextBox1
a.Cells(uf, "E") = UserForm2.TextBox2
a.Cells(uf, "F") = UserForm2.ListBox1.List(x, 0)
a.Cells(uf, "G") = UserForm2.ListBox1.List(x, 1)
a.Cells(uf, "H") = UserForm2.ListBox1.List(x, 2)
a.Cells(uf, "I") = CDec(UserForm2.ListBox1.List(x, 3))
a.Cells(uf, "J") = CDec(ListBox1.List(x, 5))
uf = uf + 1
Next x


Set b = Sheets("Factura")
b.Range("A9:I24").ClearContents
b.Range("H2") = UserForm2.Label2
b.Range("H3") = UserForm2.TextBox3
b.Range("B6") = UserForm2.TextBox1
b.Range("G6") = UserForm2.TextBox2
fila = 9
For x = 0 To UserForm2.ListBox1.ListCount - 1
b.Cells(fila, "A") = UserForm2.ListBox1.List(x, 0)
b.Cells(fila, "B") = UserForm2.ListBox1.List(x, 1)
b.Cells(fila, "E") = UserForm2.ListBox1.List(x, 2)
b.Cells(fila, "F") = CDec(UserForm2.ListBox1.List(x, 3))
b.Cells(fila, "G") = CDec(ListBox1.List(x, 4))
b.Cells(fila, "H") = b.Cells(fila, "F") * 0.16
b.Cells(fila, "I") = (b.Cells(fila, "F") * b.Cells(fila, "G")) * 1.16
fila = fila + 1
Next x


Application.PrintCommunication = True
Sheets("Factura").Activate
Sheets("Factura").Range("E60,G60,I60").NumberFormat = "#,##0.00 ""U$S"""
With ActiveSheet.PageSetup
.PrintArea = "$A$1:$I$60"
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Application.PrintCommunication = True

nomfic = UserForm2.Label2 & UserForm2.TextBox3 & UserForm2.TextBox1
nomfic = Replace(nomfic, "/", "")
rutadir = ActiveWorkbook.Path & "\Comprobantes VTA"
rutapdf = rutadir & "\" & nomfic & ".pdf"
rutaxls = rutadir & "\" & nomfic & ".xlsx"

'Verifica que la carpeta exista
If Dir(rutadir, vbDirectory) = "" Then
MkDir rutadir
End If

'Verfica si existe el archivo
Set verexi = CreateObject("Scripting.FileSystemObject")
If verexi.FileExists(rutadir) Then
MsgBox ("El comprobante de venta ya fue registrado"), vbInformation, "AVISO"
Exit Sub
Else
ActiveSheet.Copy
ActiveWorkbook.SaveAs Filename:=rutaxls, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close True
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=rutapdf, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=True, OpenAfterPublish:=False
End If
'Imprime
ActiveSheet.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False

'Envia Mail
Set b = Worksheets("Factura")
Asun = "Factura N° " & Val(UserForm2.Label2.Caption) & " de fecha " & UserForm2.TextBox3 & " " & UserForm2.TextBox1
Cop = ""
SCop = ""

busco = UserForm2.TextBox1
Set codigo = Sheets("Clientes").Range("C1:C1000").Find(busco, LookIn:=xlValues, LookAt:=xlWhole)
If Not codigo Is Nothing Then
uf = codigo.Row
Dest = Sheets("Clientes").Cells(uf, "E")
End If


'Envia mail
Set OApp = CreateObject("Outlook.Application")
Set OMail = OApp.CreateItem(0)
logo = ActiveWorkbook.Path & "\Excel.jpg"

sini = "<Div><H3><B>Estimado enviamos factura N° " & Val(UserForm2.Label2.Caption) & " por articulos comprados a nuestra empresa. </B></H3><br></Div>"
'stbl = TableHTML
spie = "<Div> <IMG SRC=""" & logo & """><B><FONT COLOR= ""red "" >PROGRAMAR EXCEL <a href=""http://programarexcel.com"">Visit PROGRAMAR EXCEL.com</a> <a href=""https://www.youtube.com/channel/UCTKYXi9ljxxOAXXKgwWDDpQ"">Visit YOUTUBE CHANEL</a> </FONT> <br>  Lincoln Road Mall <br> Miami Beach <br> Florida, USA <br> <br>" & _
       "Tel: 99999999<br> Fax : 99999999 <br> Whatsapp : 99999999 <br> E -mail: marcrodos@yahoo.es <br><br><FONT COLOR="" green ""> <FONT FACE= ""Webdings "" >P </FONT> Antes de imprimir este e-mail piense bien si es necesario hacerlo: El medioambiente es cosa de todos !</FONT><br><br>" & _
       "* * * * * * * * AVISO DE CONFIDENCIALIDAD * * * * * * * * * * <br><br>Este mensaje de correo electrónico y sus anexos (si los hay) están destinados exclusivamente para el uso del destinatario del mismo, y como tal, siguen siendo propiedad de PROGRAMAR EXCEL.COM. Este mensaje y los archivos adjuntos (si los hay) pueden contener información que es confidencial, privilegiada y exenta de divulgación en virtud de la ley aplicable. Si usted no es el destinatario de este mensaje, se le prohíbe la lectura, divulgación, reproducción, distribución, difusión o utilización de cualquier forma esta transmisión. La entrega de este mensaje a cualquier persona que no sea el destinatario no tiene la intención de renunciar a cualquier derecho o privilegio. Si usted ha recibido este mensaje por error, por favor notifique inmediatamente al remitente por e-mail y elimine de inmediato este mensaje de su sistema.</Div>"
sbdy = sini & vbNewLine & vbNewLine & vbNewLine & vbNewLine & vbNewLine
sbdy = sbdy & vbNewLine & vbNewLine & stbl & vbNewLine & vbNewLine
sbdy = sbdy & spie

With OMail
.To = Dest
.CC = Cop
.BCC = SCop
.Subject = Asun
.Attachments.Add rutapdf
.Display
.HTMLBody = sbdy
.Send
End With
Set OMail = Nothing
Set OApp = Nothing


Sheets("DbFac").Select
UserForm2.TextBox1 = Clear
UserForm2.TextBox2 = Clear
UserForm2.TextBox3 = Clear
UserForm2.ListBox1.Clear
UserForm2.Label14 = Clear
UserForm2.Label15 = Clear
UserForm2.Label16 = Clear

uf = Sheets("DbFac").Range("A" & Rows.Count).End(xlUp).Row
Nfac = Application.WorksheetFunction.Max(Sheets("DbFac").Range("A2" & ":A" & uf + 1)) + 1
Label2.Caption = Format(Nfac, "00000000")
MsgBox "El comprobante de venta se grabó en la base de datos, se guardo en PDF, XLSX y envió por Mail", vbInformation, "AVISO"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Private Sub CommandButton6_Click()
Unload UserForm2
End Sub

Private Sub Label4_Click()
ActiveWorkbook.FollowHyperlink "http://www.programarexcel.com/p/home.html"
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
On Error Resume Next
respuesta = MsgBox("¿Seguro desea eliminar el dato seleccionado?", vbCritical + vbYesNo)
If respuesta = 6 Then
Set a2 = Sheets("Articulos")
filaedit = a2.Range("A" & Rows.Count).End(xlUp).Row
fila = ListBox1.ListIndex
cod = UserForm2.ListBox1.List(fila, 0)
can = UserForm2.ListBox1.List(fila, 4)
UserForm2.ListBox1.RemoveItem ListBox1.ListIndex
End If
For x = 0 To UserForm2.ListBox1.ListCount - 1
t = CDec(UserForm2.ListBox1.List(x, 6))
tot = tot + t
t = 0
Next x

Set codigo = a2.Range("B2:B" & filaedit).Find(cod, LookIn:=xlValues, LookAt:=xlWhole)
If Not codigo Is Nothing Then
stodir = codigo.Row
End If
stoold = a2.Cells(stodir, "G")
a2.Cells(stodir, "G") = stoold + can
can = Empty
cod = Empty
UserForm2.Label16.Caption = "Total  " & Format(tot, "#,##0.00;-#.##0,00")
UserForm2.Label14.Caption = "Subtotal  " & Format((tot / 1.16), "#,##0.00;-#.##0,00")
UserForm2.Label15.Caption = "IVA  " & Format(((tot / 1.16) * 0.16), "#,##0.00;-#.##0,00")
End Sub

Private Sub ListBox2_Click()
On Error Resume Next
ctr = 1
TextBox1 = Empty
TextBox2 = Empty
fila = Me.ListBox2.ListIndex
Me.TextBox1 = ListBox2.List(fila, 2)
Me.TextBox2 = ListBox2.List(fila, 3)
ListBox2.Visible = False
ctr = 0
End Sub

Private Sub TextBox1_AfterUpdate()
creg = ListBox2.ListCount
If creg = 0 Then
ListBox2.Visible = False
RESP = MsgBox("Presione SI para cargar cliente o NO para cancelar y proseguir la realización del comprobante de venta", vbYesNo, "REQUIERE CARGAR EL CLIENTE NUEVO")
    If RESP = 6 Then
    uf = Sheets("Clientes").Range("A" & Rows.Count).End(xlUp).Row
    UserForm4.TextBox1 = Application.WorksheetFunction.Max(Sheets("Clientes").Range("A2" & ":A" & uf + 1)) + 1
    UserForm4.TextBox3 = UserForm2.TextBox1
    UserForm4.TextBox2.SetFocus
    UserForm4.Show
    Else
    UserForm2.TextBox2.Locked = False
    UserForm2.TextBox2 = Empty
    UserForm2.TextBox2.SetFocus
    End If
End If
End Sub

Private Sub TextBox1_Change()
If ctr = 1 Then Exit Sub
On Error Resume Next
Set b = Sheets("Clientes")
uf = b.Range("A" & Rows.Count).End(xlUp).Row
If Trim(TextBox1.Value) = "" Then
   Me.ListBox2.RowSource = "Clientes!A2:D" & uf
   Exit Sub
End If
b.AutoFilterMode = False
Me.ListBox2.Clear
Me.ListBox2.RowSource = Clear
Me.ListBox2.ColumnCount = 4
For i = 2 To uf
   strg = b.Cells(i, 3).Value
   If UCase(strg) Like "*" & UCase(TextBox1.Value) & "*" Then
       Me.ListBox2.AddItem b.Cells(i, 1)
       Me.ListBox2.List(Me.ListBox2.ListCount - 1, 1) = b.Cells(i, 2)
       Me.ListBox2.List(Me.ListBox2.ListCount - 1, 2) = b.Cells(i, 3)
       Me.ListBox2.List(Me.ListBox2.ListCount - 1, 3) = b.Cells(i, 4)
   End If
Next i
Me.ListBox2.ColumnWidths = "20 pt;50 pt;80 pt;80"
ListBox2.Visible = True
End Sub

Private Sub UserForm_Initialize()
uf = Sheets("DbFac").Range("A" & Rows.Count).End(xlUp).Row
Nfac = Application.WorksheetFunction.Max(Sheets("DbFac").Range("A2" & ":A" & uf + 1)) + 1
Label2.Caption = Format(Nfac, "00000000")
Me.ListBox1.ColumnCount = 7
Me.ListBox1.ColumnWidths = "70 pt;150 pt;60 pt;60 pt;60 pt;60 pt;60 pt"
TextBox3.SetFocus
End Sub


Código que se inserta en un formulario

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
On Error Resume Next
Dim t As Variant, tot As Variant
If UserForm3.TextBox1 = Empty Or UserForm3.TextBox1 = 0 Then Exit Sub
If UserForm2.ListBox1.ListCount > 50 Then
MsgBox ("No puede ingresar más de 16 articulos por factura"), vbCritical, "AVISO"
Exit Sub
End If
Set a1 = Sheets("Articulos")
If KeyCode = 13 Then
can = Val(UserForm3.TextBox1)
UserForm2.ListBox1.AddItem cod
UserForm2.ListBox1.List(UserForm2.ListBox1.ListCount - 1, 1) = art
UserForm2.ListBox1.List(UserForm2.ListBox1.ListCount - 1, 2) = mar
UserForm2.ListBox1.List(UserForm2.ListBox1.ListCount - 1, 3) = Format(pv, "#,##0.0000;-#.##0,0000")
UserForm2.ListBox1.List(UserForm2.ListBox1.ListCount - 1, 4) = Format(can, "#,##0.00;-#.##0,00")
UserForm2.ListBox1.List(UserForm2.ListBox1.ListCount - 1, 5) = Format((pv * 0.16), "#,##0.00;-#.##0,00")
UserForm2.ListBox1.List(UserForm2.ListBox1.ListCount - 1, 6) = Format(((can * pv) * 1.16), "#,##0.00;-#.##0,00")
Unload UserForm3

For x = 0 To UserForm2.ListBox1.ListCount - 1
t = CDec(UserForm2.ListBox1.List(x, 6))
tot = tot + t
t = 0
Next x


UserForm2.Label16.Caption = "Total  " & Format(tot, "#,##0.00 ""U$S""")
UserForm2.Label14.Caption = "Subtotal  " & Format((tot / 1.16), "#,##0.00 ""U$S""")
UserForm2.Label15.Caption = "IVA  " & Format(((tot / 1.16) * 0.16), "#,##0.00 ""U$S""")
stoold = a1.Cells(stodir, "G")
a1.Cells(stodir, "G") = a1.Cells(stodir, "G") - can
End If
End Sub


Código que se inserta en un formulario


Private Sub CommandButton1_Click()
If UserForm4.TextBox1 = Empty Or UserForm4.TextBox2 = Empty Or UserForm4.TextBox3 = Empty Or UserForm4.TextBox4 = Empty Then Exit Sub
Set a = Sheets("Clientes")
uf = a.Range("A" & Rows.Count).End(xlUp).Row + 1
a.Cells(uf, "A") = Val(UserForm4.TextBox1)
a.Cells(uf, "B") = UserForm4.TextBox2
a.Cells(uf, "C") = UserForm4.TextBox3
a.Cells(uf, "D") = UserForm4.TextBox4
a.Cells(uf, "E") = UserForm4.TextBox5
UserForm2.TextBox1 = UserForm4.TextBox3
UserForm2.TextBox2 = UserForm4.TextBox4
MsgBox ("Los datos se gaurdarón con éxito"), vbInformation, "AVISO"
Unload UserForm4
End Sub

Private Sub CommandButton2_Click()
Unload UserForm4
End Sub



Si te fue de utilidad puedes INVITARME UN CAFÉ y de esta manera ayudar a seguir manteniendo la página, CLICK para descargar en ejemplo en forma gratuita.


If this post was helpful INVITE ME A COFFEE and so help keep up the page, CLICK to download free example.


Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends