PROGRAMAR EN VBA MACROS DE EXCEL: Resultados de búsqueda para uf
Mostrando las entradas para la consulta uf ordenadas por relevancia. Ordenar por fecha Mostrar todas las entradas
Mostrando las entradas para la consulta uf ordenadas por relevancia. Ordenar por fecha Mostrar todas las entradas

Como dar formato a celdas automaticamente





En el presente post muestro como dar formato a las celdas en forma automática, para ello determina el rango variable y le otorga el formato determinado en la macro, el objetivo del ejemplo es dar formato a una tabla en Excel, para que funcione correctamente la macro se debe posicionar en la primer fila y primer columna de la tabla y ejecutar la macro que dará formato determinando automáticamente el rango de la tabla.

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.


  


La macro determina el rango donde se encuentran los datos a dar formato,  con la variante que se pueden agregar filas o columnas y la macro determinará en forma automática el rango al cual se le debe dar formato.

El formato consiste en darle a la tabla que está en Excel bordes; a los números da formato agregando separador de miles y dos dígitos después de la coma, el formato de fecha "dd/mm/yyyy" a los datos de fecha, alinea en forma centrada los datos; tamaño de fuente igual a 10 y formato de negrita, si se requiere aumentar el tamaño de la fila se puede usar el código: Range ("A1"). RowHeigt=30; el único requisito es que para dar formato a la tabla se debe posicionar en la primer fila y columna de la tabla.

En el vídeo encontrarás una explicación más gráfica y detallando paso a paso su funcionamiento, te sugiero que lo veas, de esa manera podrás modificar la macro a tu necesidad, por favor suscribe el canal y blog, recibirás en tu una notificación en tu correo cada vez que se presente un post con ejemplos de macro, que puedes descargar gratuitamente.

Suscribe 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 formato()
Application.ScreenUpdating = False
Dim pf As Long, uf As Long
Set a = Sheets(ActiveSheet.Name)
pf = ActiveCell.Row
pc = ActiveCell.Address
pwc = Mid(pc, InStr(pc, "$") + 1, InStr(2, pc, "$") - 2)

uf = a.Range("A" & Rows.Count).End(xlUp).Row
uc = a.Cells(1, Columns.Count).End(xlToLeft).Address
wc = Mid(uc, InStr(uc, "$") + 1, InStr(2, uc, "$") - 2)

a.Range(pwc & pf & ":" & wc & uf).Borders(xlInsideHorizontal).LineStyle = xlContinuous
a.Range(pwc & pf & ":" & wc & uf).Borders(xlInsideVertical).LineStyle = xlContinuous
a.Range(pwc & pf & ":" & wc & pf).Borders(xlEdgeLeft).LineStyle = xlContinuous
a.Range(pwc & pf & ":" & wc & pf).Borders(xlEdgeLeft).Weight = xlMedium
a.Range(pwc & pf & ":" & wc & pf).Borders(xlEdgeTop).LineStyle = xlContinuous
a.Range(pwc & pf & ":" & wc & pf).Borders(xlEdgeTop).Weight = xlMedium
a.Range(pwc & pf & ":" & wc & pf).Borders(xlEdgeBottom).LineStyle = xlContinuous
a.Range(pwc & pf & ":" & wc & pf).Borders(xlEdgeBottom).Weight = xlMedium
a.Range(pwc & pf & ":" & wc & pf).Borders(xlEdgeRight).LineStyle = xlContinuous
a.Range(pwc & pf & ":" & wc & pf).Borders(xlEdgeRight).Weight = xlMedium


a.Range(pwc & pf + 1 & ":" & wc & uf).Borders(xlEdgeLeft).LineStyle = xlContinuous
a.Range(pwc & pf + 1 & ":" & wc & uf).Borders(xlEdgeLeft).Weight = xlMedium
a.Range(pwc & pf + 1 & ":" & wc & uf).Borders(xlEdgeTop).LineStyle = xlContinuous
a.Range(pwc & pf + 1 & ":" & wc & uf).Borders(xlEdgeTop).Weight = xlMedium
a.Range(pwc & pf + 1 & ":" & wc & uf).Borders(xlEdgeBottom).LineStyle = xlContinuous
a.Range(pwc & pf + 1 & ":" & wc & uf).Borders(xlEdgeBottom).Weight = xlMedium
a.Range(pwc & pf + 1 & ":" & wc & uf).Borders(xlEdgeRight).LineStyle = xlContinuous
a.Range(pwc & pf + 1 & ":" & wc & uf).Borders(xlEdgeRight).Weight = xlMedium

a.Range(pwc & uf & ":" & wc & uf).Borders(xlEdgeLeft).LineStyle = xlContinuous
a.Range(pwc & uf & ":" & wc & uf).Borders(xlEdgeLeft).Weight = xlMedium
a.Range(pwc & uf & ":" & wc & uf).Borders(xlEdgeTop).LineStyle = xlContinuous
a.Range(pwc & uf & ":" & wc & uf).Borders(xlEdgeTop).Weight = xlMedium
a.Range(pwc & uf & ":" & wc & uf).Borders(xlEdgeBottom).LineStyle = xlContinuous
a.Range(pwc & uf & ":" & wc & uf).Borders(xlEdgeBottom).Weight = xlMedium
a.Range(pwc & uf & ":" & wc & uf).Borders(xlEdgeRight).LineStyle = xlContinuous
a.Range(pwc & uf & ":" & wc & uf).Borders(xlEdgeRight).Weight = xlMedium

'a.Range("C" & pf + 1 & ":" & wc & uf).NumberFormat = "dd/mm/yyyy"
a.Range("C" & pf + 1 & ":" & wc & uf).NumberFormat = "#,##0.00;-#,##0.00"
a.Range(pwc & pf & ":" & wc & pf).HorizontalAlignment = xlCenter
a.Range(pwc & pf & ":" & wc & pf).VerticalAlignment = xlCenter
a.Range(pwc & pf & ":" & wc & pf).Font.Size = 10
a.Range(pwc & pf & ":" & wc & pf).Font.Bold = True
'a.Range(pwc & pf).RowHeight = 30

'a.Cells(uf, pwc) = "Total"
'a.Range(pwc & uf & ":" & wc & uf).Font.Bold = True

'For j = 4 To 11
'a.Cells(uf, j) = Application.WorksheetFunction.Sum(a.Range(Cells(pf + 1, j), Cells(uf - 1, j)))
'Next j

'a.Range(pwc & pf & ":" & wc & pf).EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Sub borraformato()
ActiveSheet.Cells.ClearFormats
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 copiar tablas o cuadros de Word a Excel





Hoy te presento una macro que permite importar tablas de Word a una hoja de Excel, en varias oportunidades es posible que se haya tenido que pasar tablas de Word a Excel, si son pocas no es problema se copia y pega y listo, luego se le da formato deseado y problema solucionado, pero cuando son varias, ya toma un poco más de tiempo y mucho más si esto se debe hacer todos los días en forma repetitiva; te habrás preguntado como se puede realizar automáticamente, en este ejemplo enseño como pasar tablas o cuadro de Word a Excel con solo apretar un botón.


Otros post relacionados con macros que permiten manejar Word desde Excel:
Como crear un archivo de Word con Excel
Como abrir un archivo de Word con Excel
Como conectar Excel con Word crear archivo e insertar texto en Word
Como dar formato a texto de Word desde Excel 
Como abrir modificar e imprimir archivo de Word con macro desde Excel
Como modificar una plantilla de Word con macro de Excel
Como rellenar pagare con datos de Excel conectando con Word
Como crear cartas en Word con clientes listados en Excel
Como copiar tablas o cuadros de Word a Excel


Antes de continuar 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 ejemplo se puede descargar desde el link del final en forma GRATUITA, es un archivo comprimido donde hay un archivo de Excel con la Macro y un archivo de Word con las tablas de ejemplo que se importarán a Excel, se deben descromprimir los archivos y guardar los dos juntos en cualquier carpeta de la PC, pero juntos.

La macro que permite importar tablas de Word a Excel, en primero lugar abre el archivo de Word, luego se procede a recorrer todas las tablas de Word, en en ella todas las columnas y filas que componen la tablas, pasando los datos de Word a Excel; luego de haber importado los datos de Word, procede a dar formato a las celdas de Excel.

El procedimiento descripto lo hace con todas las tablas que hubiese en Word, al final sale un mensaje mostrando la cantidad de tablas importadas, en el vídeo encontrarás una explicación más detallada y gráfica del funcionamiento de la macro, el código completo del ejemplo se encuentra al final del post.

Suscribe 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




Public f, c
Sub ImportaTablaWord()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim objWord As Word.Application, wdDoc As Word.Document
Dim fila As Long, col As Long, cr As Long, conta As Integer, ti As Integer, tt As Integer
On Error Resume Next
Set a = Sheets(ActiveSheet.Name)
a.Cells.Clear
fila = 1
col = 1
conta = 0
nom = ActiveWorkbook.Name
pto = InStr(nom, ".")
nomarch = Left(nom, pto - 1)
ruta = ThisWorkbook.Path & "\" & nomarch & ".docx"
uf = a.Range("A" & Rows.Count).End(xlUp).Row
Set objWord = CreateObject("Word.Application")
objWord.DisplayAlerts = wdAlertsNone
objWord.Visible = True
Set wdDoc = objWord.Documents.Open(ruta)
With wdDoc
tt = wdDoc.Tables.Count
For x = 1 To tt
    With .Tables(x)
    For f = 1 To .Rows.Count
        For c = 1 To .Columns.Count
        a.Cells(fila, c) = WorksheetFunction.Clean(.Cell(f, c).Range.Text)
        Next c
    fila = fila + 1
    Next f
    End With
conta = conta + 1
fila = fila + 2
Call formato
Next x

End With
wdDoc.Close
MsgBox ("Se han importado " & conta & " tablas de Word a Excel"), vbInformation, "AVISO"
objWord.Quit
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub


Sub formato()
Dim pf As Long, uf As Long
Set a = Sheets(ActiveSheet.Name)
uf = a.Range("A" & Rows.Count).End(xlUp).Row

pf = a.Range("A" & uf).End(xlUp).Row
pc = a.Cells(f, c - c + 1).Address
pwc = Mid(pc, InStr(pc, "$") + 1, InStr(2, pc, "$") - 2)

uf = uf
uc = a.Cells(f, c - 1).Address
wc = Mid(uc, InStr(uc, "$") + 1, InStr(2, uc, "$") - 2)

a.Range(pwc & pf & ":" & wc & uf).Borders(xlInsideHorizontal).LineStyle = xlContinuous
a.Range(pwc & pf & ":" & wc & uf).Borders(xlInsideVertical).LineStyle = xlContinuous
a.Range(pwc & pf & ":" & wc & pf).Borders(xlEdgeLeft).LineStyle = xlContinuous
a.Range(pwc & pf & ":" & wc & pf).Borders(xlEdgeLeft).Weight = xlMedium
a.Range(pwc & pf & ":" & wc & pf).Borders(xlEdgeTop).LineStyle = xlContinuous
a.Range(pwc & pf & ":" & wc & pf).Borders(xlEdgeTop).Weight = xlMedium
a.Range(pwc & pf & ":" & wc & pf).Borders(xlEdgeBottom).LineStyle = xlContinuous
a.Range(pwc & pf & ":" & wc & pf).Borders(xlEdgeBottom).Weight = xlMedium
a.Range(pwc & pf & ":" & wc & pf).Borders(xlEdgeRight).LineStyle = xlContinuous
a.Range(pwc & pf & ":" & wc & pf).Borders(xlEdgeRight).Weight = xlMedium


a.Range(pwc & pf + 1 & ":" & wc & uf).Borders(xlEdgeLeft).LineStyle = xlContinuous
a.Range(pwc & pf + 1 & ":" & wc & uf).Borders(xlEdgeLeft).Weight = xlMedium
a.Range(pwc & pf + 1 & ":" & wc & uf).Borders(xlEdgeTop).LineStyle = xlContinuous
a.Range(pwc & pf + 1 & ":" & wc & uf).Borders(xlEdgeTop).Weight = xlMedium
a.Range(pwc & pf + 1 & ":" & wc & uf).Borders(xlEdgeBottom).LineStyle = xlContinuous
a.Range(pwc & pf + 1 & ":" & wc & uf).Borders(xlEdgeBottom).Weight = xlMedium
a.Range(pwc & pf + 1 & ":" & wc & uf).Borders(xlEdgeRight).LineStyle = xlContinuous
a.Range(pwc & pf + 1 & ":" & wc & uf).Borders(xlEdgeRight).Weight = xlMedium

a.Range(pwc & uf & ":" & wc & uf).Borders(xlEdgeLeft).LineStyle = xlContinuous
a.Range(pwc & uf & ":" & wc & uf).Borders(xlEdgeLeft).Weight = xlMedium
a.Range(pwc & uf & ":" & wc & uf).Borders(xlEdgeTop).LineStyle = xlContinuous
a.Range(pwc & uf & ":" & wc & uf).Borders(xlEdgeTop).Weight = xlMedium
a.Range(pwc & uf & ":" & wc & uf).Borders(xlEdgeBottom).LineStyle = xlContinuous
a.Range(pwc & uf & ":" & wc & uf).Borders(xlEdgeBottom).Weight = xlMedium
a.Range(pwc & uf & ":" & wc & uf).Borders(xlEdgeRight).LineStyle = xlContinuous
a.Range(pwc & uf & ":" & wc & uf).Borders(xlEdgeRight).Weight = xlMedium

'a.Range("D" & pf + 1 & ":" & wc & uf).NumberFormat = "#,##0.00;-#,##0.00"
a.Range(pwc & pf & ":" & wc & pf).HorizontalAlignment = xlCenter
a.Range(pwc & pf & ":" & wc & pf).VerticalAlignment = xlCenter
a.Range(pwc & pf & ":" & wc & pf).Font.Size = 10
a.Range(pwc & pf & ":" & wc & pf).Font.Bold = True
a.Range(pwc & pf).RowHeight = 15

'a.Cells(uf, pwc) = "Total"
'a.Range(pwc & uf & ":" & wc & uf).Font.Bold = True

'For j = 4 To 11
'a.Cells(uf, j) = Application.WorksheetFunction.Sum(a.Range(Cells(pf + 1, j), Cells(uf - 1, j)))
'Next j

a.Range(pwc & pf & ":" & wc & pf).EntireColumn.AutoFit
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      
4.70/5 – 1379