Mostrar hoja de entradas en listbox pero solo un registro por nº de pedido (vba excel)
Lo primero, muy agradecido por toda la ayuda recibida en este foro, por todos y cada uno de los expertos. GRACIAS!
Ahora la duda de hoy! JE JE.
Tengo un form donde muestro varias columnas de la hoja entradas. Pero me muestra, todos los registros de cada nº de compra. Pero solo necesito que me muestre un registro por cada nº de compra (da igual que la compra tenga 1 que 8 filas).
Con imágenes creo que me explicare mejor.
Como veis, hago la búsqueda por nombre de proveedor y me trae la info.
Pero necesito que tan solo me muestre un registro por cada nº de compra.
Esta captura la hice manual pero debería de quedar así:
Dejo el codigo que tengo en el boton buscar:
Private Sub lb_buscar_Click()
'Por.Dante Amor
ListBox1.Clear
If txt_buscar.Value = "" Then
MsgBox "Escribe el nombre de un proveedor o cliente a buscar", vbInformation, ""
Exit Sub
End If
Set r = h1.Columns("K")
Set b = r.Find(txt_buscar, lookat:=xlPart)
If Not b Is Nothing Then
celda = b.Address
Do
'detalle
ListBox1. AddItem h1. Cells(b.Row, "A")
ListBox1. List(ListBox1.ListCount - 1, 1) = h1. Cells(b.Row, "B")
ListBox1. List(ListBox1.ListCount - 1, 2) = h1. Cells(b.Row, "D")
ListBox1. List(ListBox1.ListCount - 1, 3) = h1. Cells(b.Row, "F")
ListBox1. List(ListBox1.ListCount - 1, 4) = h1. Cells(b.Row, "H")
ListBox1. List(ListBox1.ListCount - 1, 5) = h1. Cells(b.Row, "K")
ListBox1. List(ListBox1.ListCount - 1, 6) = h1. Cells(b.Row, "T")
ListBox1.List(ListBox1.ListCount - 1, 7) = b.Row
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> celda
End If
End Sub
2 Respuestas
¿Esto es lo que buscas?
Entonces esta es la macro, funciona asi crea una tabla temporal autoborrable en la cual se copian las columnas que se cargaran en el listbox, ya copiadas entonces aplica una eliminacion de duplicados dejando solo registros unicos y estos son cargados a traves de una segunda tabla temporal al listbox en este ejemplo el filtrado se hace a traves del textbox1 con el evento afterupdate escribes parte del nombre, das enter y te filtrara todos aquellos nombres que contengan esta parte del nombre, una vez que cierres el formulario las tablas se borraran mediante la macro borrar_al_salir que esta ligada a la X del formulario aunque tambien puedes ligarla a un boton.
Private Sub ListBox1_Click()
End Sub
Private Sub TextBox1_AfterUpdate()
palabra = TextBox1.Text
Set filtro = Range("filtro")
rango = filtro.Address
With filtro
filas = .Rows.Count
col = .Columns.Count
End With
Range(rango).AutoFilter Field:=8, Criteria1:="=*" & palabra & "*", _
Operator:=xlAnd
cuenta = WorksheetFunction.Subtotal(2, filtro.Columns(1)) + 1
filtro.Rows(filas + 2).CurrentRegion.Clear
Set destino = filtro.Rows(filas + 2).Resize(cuenta, col)
filtro.SpecialCells(xlCellTypeVisible).Copy
With destino
.PasteSpecial
Set destino = .Rows(2).Resize(.Rows.Count)
End With
With ListBox1
.RowSource = destino.Address
.ColumnCount = filtro.Columns.Count
.ColumnHeads = True
End With
Range(rango).AutoFilter Field:=8
End Sub
Sub copiar_datos()
Set datos = Range("a1").CurrentRegion
With datos
col = .Columns.Count
filas = .Rows.Count
.Columns(col + 3).Resize(1000, 100).Clear
Set destino = .Columns(col + 3).Resize(filas, 9)
Union(.Columns(1), .Columns(2), .Columns(4), .Columns(5), _
.Columns(6), .Columns(8), .Columns(10), .Columns(11), _
.Columns(20)).Copy
End With
With destino
.PasteSpecial xlPasteValues
.Columns(2).NumberFormat = "dd/mm/yyyy"
.RemoveDuplicates Columns:=Array(1, 2, 3, 8, 9)
.CurrentRegion.Name = "filtro"
End With
Set datos = Nothing: Set destino = Nothing
End Sub
Private Sub UserForm_Initialize()
copiar_datos
End Sub
Sub borrar_al_salir()
Set filtro = Range("filtro")
rango = filtro.Address
Range(rango).AutoFilter Field:=8
filtro.Resize(1000, 1000).Clear
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
borrar_al_salir
End Sub
¡Gracias!
Me agrega como una tabla en mi hoja entradas. Pero no quiero que me toque nada de mi bbdd.
Ya le envíe el archivo a adriel.
Aunque se agradece tu ayuda James Bond.
Mi email es [email protected]
¡Gracias!
Prueba con esto
Private Sub lb_buscar_Click()
'
ActiveWorkbook.Worksheets("ENTRADAS").ListObjects("tbl_entradas").Sort. _
SortFields.Clear
ActiveWorkbook.Worksheets("ENTRADAS").ListObjects("tbl_entradas").Sort. _
SortFields.Add Key:=Range("tbl_entradas[[#All],[No. ENTRADA]]"), SortOn:= _
xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("ENTRADAS").ListObjects("tbl_entradas").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ListBox1.Clear
If txt_buscar.Value = "" Then
MsgBox "Escribe el nombre de un proveedor o cliente a buscar", vbInformation, ""
Exit Sub
End If
Set r = h1.Columns("K")
Set b = r.Find(txt_buscar, lookat:=xlPart)
If Not b Is Nothing Then
celda = b.Address
ant = h1.Cells(b.Row - 1, "A")
Do
'detalle
If ant <> h1.Cells(b.Row, "A") Then
ListBox1. AddItem h1. Cells(b.Row, "A")
ListBox1. List(ListBox1.ListCount - 1, 1) = h1. Cells(b.Row, "B")
ListBox1. List(ListBox1.ListCount - 1, 2) = h1. Cells(b.Row, "D")
ListBox1. List(ListBox1.ListCount - 1, 3) = h1. Cells(b.Row, "F")
ListBox1. List(ListBox1.ListCount - 1, 4) = h1. Cells(b.Row, "H")
ListBox1. List(ListBox1.ListCount - 1, 5) = h1. Cells(b.Row, "K")
ListBox1. List(ListBox1.ListCount - 1, 6) = h1. Cells(b.Row, "T")
ListBox1.List(ListBox1.ListCount - 1, 7) = b.Row
End If
ant = h1.Cells(b.Row, "A")
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> celda
End If
End Sub
James Bond te atendió con la macro primero, y no debes negar de su ayuda, porque considero una falta si te quiere dar el apoyo de buena voluntad. - Adriel Ortiz Mangia
Adriel Ortiz Mangia gracias por tu comentario, si no quiere mi ayuda ni modo lo tendré en cuenta para la próxima vez que este usuario solicite ayuda - James Bond
No la negué, para nada soy desagradecido. Solo que esa macro no terminaba de funcionar.Si ofendí, no fue mi intención. - fjpg81