Inconveneinte al filtrar datos y copiar a libro nuevo
Para DanteAmor:
Cordial saludo
Estoy creando un reporte para lo cual debo filtrar información de dos hojas (Entradas, Salidas), utilizando como dato de filtro información ingresada en un Userform (Informe_por_Item), para esto he adaptado un código que usted me suministro hace algún tiempo, el cual me funciona perfectamente cuando el dato buscado existe en las dos hojas, pero cuando no existe o existe solo en alguna de las dos hojas, me lleva información que no corresponde con lo buscado, lo que necesito es realizar validación para que solo me lleve al nuevo libro la información relacionada con el dato buscado y que si el dato no existe en alguna de las 2 hojas, solo lleve la información que exista para el dato buscado, el siguiente es el código.
Private Sub Btn_Aceptar_Click()
'Act.Por.Gilber
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("ENTRADAS")
Set h3 = l1.Sheets("SALIDAS")
h1.Unprotect "1717171"
h3.Unprotect "1717171"
'Entradas
u = h1.Range("A" & Rows.Count).End(xlUp).Row
If h1.AutoFilterMode Then h1.AutoFilterMode = False
item = Cmb_CodigoItem
h1.Range("A1:J" & u).AutoFilter Field:=1, Operator:=xlFilterValues, Criteria1:=Array(1, item)
Set l2 = Workbooks.Add 'Adicionar libro nuevo para informe
Set h2 = l2.Sheets(1)
j = 2
cols = Array(6, 4, 5, 3, 9, 8) 'Columnas donde esta la informacion q debe ir al informe
For i = LBound(cols) To UBound(cols)
h1.Range(h1.Cells(2, cols(i)), h1.Cells(u, cols(i))).Copy h2.Cells(11, j)
j = j + 1
Next
'Salidas
ult = h3.Range("A" & Rows.Count).End(xlUp).Row
If h3.AutoFilterMode Then h3.AutoFilterMode = False
item = Cmb_CodigoItem
h3.Range("A1:I" & ult).AutoFilter Field:=1, Operator:=xlFilterValues, Criteria1:=Array(1, item)
Set h2 = l2.Sheets(1)
k = 8
cols = Array(6, 4, 5, 3, 8, 7) 'Columnas donde esta la informacion q debe ir al informe
For s = LBound(cols) To UBound(cols)
h3.Range(h3.Cells(2, cols(s)), h3.Cells(ult, cols(s))).Copy h2.Cells(11, k)
k = k + 1
Next
If h1.AutoFilterMode Then h1.AutoFilterMode = False
If h3.AutoFilterMode Then h3.AutoFilterMode = False
h2.Cells(1, 1) = "INFORME MOVIMIENTO POR ITEM"
h2.Cells(3, 2) = Cmb_CodigoItem
h2.Cells(4, 2) = TextBox1
Range("A3") = "CODIGO:"
Range("A4") = "DESCRIPCION:"
Range("A5") = "CATEGORIA:"
Range("A6") = "EXISTENCIA ACTUAL:"
Range("H6") = "<== EXISTENCIA SEGUN MOVIMIENTO:"
End SubAgradezco de antemano si le es posible que me colabore con este tema
1 Respuesta
Respuesta de Dante Amor
2
Prueba lo siguiente:
Private Sub Btn_Aceptar_Click()
Dim l1 As Workbook, l2 As Workbook
Dim h1 As Worksheet, h2 As Worksheet, h3 As Worksheet
Dim f As Range, cols As Variant
Dim i As Long, j As Long, k As Long
'
Application.ScreenUpdating = False
'
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("ENTRADAS")
Set h3 = l1.Sheets("SALIDAS")
h1.Unprotect "1717171"
h3.Unprotect "1717171"
If h1.AutoFilterMode Then h1.AutoFilterMode = False
If h3.AutoFilterMode Then h3.AutoFilterMode = False
'
'Entradas
Set f = h1.Range("A:A").Find(Cmb_CodigoItem, , xlValues, xlWhole, , , False)
If Not f Is Nothing Then
Set l2 = Workbooks.Add 'Adicionar libro nuevo para informe
Set h2 = l2.Sheets(1)
k = 11 'Fila inicial hoja destino
cols = Array(6, 4, 5, 3, 9, 8) 'Columnas donde esta la informacion q debe ir al informe
For i = 1 To h1.Range("A" & Rows.Count).End(3).Row
If h1.Range("A" & i) = Cmb_CodigoItem Then
For j = LBound(cols) To UBound(cols)
h1.Range(h1.Cells(i, cols(j)), h1.Cells(i, cols(j))).Copy h2.Cells(k, j + 1)
Next
k = k + 1
End If
Next
End If
'Salidas
Set f = h3.Range("A:A").Find(Cmb_CodigoItem, , xlValues, xlWhole, , , False)
If Not f Is Nothing Then
If h2 Is Nothing Then
Set l2 = Workbooks.Add 'Adicionar libro nuevo para informe
Set h2 = l2.Sheets(1)
k = 11
End If
Cols = Array(6, 4, 5, 3, 8, 7) 'Columnas donde esta la informacion q debe ir al informe
For i = 1 To h3.Range("A" & Rows.Count).End(3).Row
If h3.Range("A" & i) = Cmb_CodigoItem Then
For j = LBound(cols) To UBound(cols)
h3.Range(h3.Cells(i, cols(j)), h3.Cells(i, cols(j))).Copy h2.Cells(k, j + 1)
Next
k = k + 1
End If
Next
End If
'
If Not h2 Is Nothing Then
h2.Range("A1") = "INFORME MOVIMIENTO POR ITEM"
h2.Range("B3") = Cmb_CodigoItem
h2.Range("B4") = TextBox1
h2.Range("A3") = "CODIGO:"
h2.Range("A4") = "DESCRIPCION:"
h2.Range("A5") = "CATEGORIA:"
h2.Range("A6") = "EXISTENCIA ACTUAL:"
h2.Range("H6") = "<== EXISTENCIA SEGUN MOVIMIENTO:"
End If
'
Application.ScreenUpdating = True
End Sub
Ante todo muchísimas gracias por la celeridad de su respuesta; intenté con el código que me envía, pero no genera el informe, he tratado de interpretar la lógica del código, pero no doy con la razón por la cual no genera el informe.
El dato del Cmb_CodigoItem, ¿está en la columna A?
¿Está escrito con mayúsculas y minúsculas al igual que los datos que están en la columna A?
Puedes poner 3 imágenes de lo que pones en el Cmb_CodigoItem y de lo que tienes en las hojas Entradas y Salidas
Hola Date Amor buen día:
Efectivamente el dato del Cmb_CodigoItem, está en la columna A, es un dato numérico, los encabezados están en la fila 1.
Adjunto imagen de hoja entradas, hoja salidas, Userform y resultado final del informe y por ultimo pongo la totalidad del código para llegar al informe de la imagen
Private Sub Btn_Aceptar_Click()
'Act.Por.Gilber
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("ENTRADAS")
Set h3 = l1.Sheets("SALIDAS")
h1.Unprotect "1717171"
h3.Unprotect "1717171"
'Entradas
u = h1.Range("A" & Rows.Count).End(xlUp).Row
If h1.AutoFilterMode Then h1.AutoFilterMode = False
item = Cmb_CodigoItem
h1.Range("A1:J" & u).AutoFilter Field:=1, Operator:=xlFilterValues, Criteria1:=Array(1, item)
Set l2 = Workbooks.Add 'Adicionar libro nuevo para informe
Set h2 = l2.Sheets(1)
j = 2
cols = Array(6, 4, 5, 3, 9, 8) 'Columnas donde esta la informacion q debe ir al informe
For i = LBound(cols) To UBound(cols)
h1.Range(h1.Cells(2, cols(i)), h1.Cells(u, cols(i))).Copy h2.Cells(11, j)
j = j + 1
Next
'Salidas
ult = h3.Range("A" & Rows.Count).End(xlUp).Row
If h3.AutoFilterMode Then h3.AutoFilterMode = False
item = Cmb_CodigoItem
h3.Range("A1:I" & ult).AutoFilter Field:=1, Operator:=xlFilterValues, Criteria1:=Array(1, item)
Set h2 = l2.Sheets(1)
k = 8
cols = Array(6, 4, 5, 3, 8, 7) 'Columnas donde esta la informacion q debe ir al informe
For s = LBound(cols) To UBound(cols)
h3.Range(h3.Cells(2, cols(s)), h3.Cells(ult, cols(s))).Copy h2.Cells(11, k)
k = k + 1
Next
'Quitar los filtros
If h1.AutoFilterMode Then h1.AutoFilterMode = False
If h3.AutoFilterMode Then h3.AutoFilterMode = False
Range("A1") = "INFORME MOVIMIENTO POR ITEM"
Range("B3") = Cmb_CodigoItem
Range("B4") = TextBox1
Range("A3") = "CODIGO:"
Range("A4") = "DESCRIPCION:"
Range("A5") = "CATEGORIA:"
Range("A6") = "EXISTENCIA ACTUAL:"
Range("H6") = "<== EXISTENCIA SEGUN MOVIMIENTO:"
'*******************************************
Dim Fin As Integer
Dim ulti As String
Dim fini As String
Fin = Hoja6.Range("A" & Rows.Count).End(xlUp).Row
If Hoja6.Cells(Fin, 1) = "" Then
Fin = Fin - 1
End If
For i = 2 To Fin
If CStr(Cmb_CodigoItem) = CStr(Hoja6.Cells(i, 1)) Then
Range("B6") = Hoja6.Cells(i, 4) 'Existencia
Range("B5") = Hoja5.Cells(i, 3) 'Categoria
Exit For
End If
Next
'Obtener saldo según el movimiento
ulti = Range("E" & Rows.Count).End(xlUp).Row
fini = Range("K" & Rows.Count).End(xlUp).Row
Range("G6") = WorksheetFunction.Sum(Range("E10:E" & ulti)) - WorksheetFunction.Sum(Range("K10:K" & fini))
'Validar si hay diferencia entre saldo sistema y saldo movimiento
If Range("B6") - Range("G6") <> 0 Then
MsgBox "El saldo del movimiento es diferente al saldo del sistema"
End If
'***********************************************
'Formato
Call Formato(l2, h2)
Application.ScreenUpdating = False
h1.Protect "1717171"
h3.Protect "1717171"
End Sub
Private Sub Cmb_CodigoItem_Enter()
Dim i As Double
Dim Final As Double
Dim tareas As String
'Cmb_CodigoItem.BackColor = &H80000005
For i = 1 To Cmb_CodigoItem.ListCount
Cmb_CodigoItem.RemoveItem 0
Next i
Final = Hoja5.Range("A" & Rows.Count).End(xlUp).Row
If Hoja5.Cells(Final, 1) = "" Then
Final = Final - 1
End If
For i = 2 To Final
tareas = Hoja5.Cells(i, 1)
Cmb_CodigoItem.AddItem (tareas)
Next
End Sub
Private Sub Cmb_CodigoItem_Click()
Dim i As Integer
Dim Final As Integer
Final = Hoja5.Range("A" & Rows.Count).End(xlUp).Row
If Hoja5.Cells(Final, 1) = "" Then
Final = Final - 1
End If
For i = 2 To Final
If CStr(Cmb_CodigoItem) = CStr(Hoja5.Cells(i, 1)) Then
TextBox1 = Hoja5.Cells(i, 2)
Exit For
End If
Next
End Sub
'*************** FORMATO
Sub Formato(l2, h2)
l2.Activate
h2.Select
Selection.Font.Bold = True
Range("A1:M1").Select
With Selection
.HorizontalAlignment = xlCenter
End With
Selection.Merge
With Selection.Interior
.ColorIndex = 10
' .Pattern = xlSolid
End With
Selection.Font.ColorIndex = 2
Selection.Font.Bold = True
'Combinar y centrar
Range("B5:I5").Merge
Range("B4:M4").Merge
Range("B3:M3").Merge
Range("H6:J6").Merge
'Emcabezados Para entradas
Range("B9") = "Nº FACTURA"
Range("C9") = "PROVEEDOR"
Range("D9") = "F.ENTRADA"
Range("E9") = "C.ENTRADA"
Range("F9") = "C.UNITARIO"
Range("G9") = "VALOR TOTAL"
'Encabezados Para salidas
Range("H9") = "Nº SALIDA"
Range("I9") = "CLIENTE"
Range("J9") = "F.SALIDA"
Range("K9") = "C.SALIDA"
Range("L9") = "C.UNITARIO"
Range("M9") = "VALOR TOTAL"
Range("B8:G8").Select
With Selection
.HorizontalAlignment = xlCenter
End With
Selection.Merge
ActiveCell.FormulaR1C1 = "ENTRADAS"
Range("B8:M8").Select
With Selection.Interior
.ColorIndex = 10
End With
Selection.Font.ColorIndex = 2
Selection.Font.Bold = True
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
End With
Range("H8:M8").Select
With Selection
.HorizontalAlignment = xlCenter
End With
Selection.Merge
With Selection.Interior
.ColorIndex = 3
End With
Range("H8:M8") = "SALIDAS"
Range("H8:M8").Font.ColorIndex = 2
Selection.Font.Bold = True
Range("B9:M9").Font.Bold = True
Range("B9:M9").Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlEdgeTop)
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
End With
'Auto ajustar columnas
Cells.Select
Cells.EntireColumn.AutoFit
'Formato de fecha
Range("J11").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "m/d/yyyy"
Range("D11").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "m/d/yyyy"
'Limpiar formulario
Me.Cmb_CodigoItem = ""
Me.TextBox1 = ""
Unload Me
Unload Informes
' l2.Activate
' h2.Select
Range("A2").Select
End Sub.
Nuevamente mil y mil gr
No puedo ver las imágenes, están muy pequeñas.
Mejor comparte tu archivo en alguna nube, pude ser google drive o dropbox.
En el archivo deberá venir mi código.
Efectivamente el dato del Cmb_CodigoItem, está en la columna A, es un dato numérico, los encabezados están en la fila 1.
Si el dato es numérico entonces prueba así:
Private Sub Btn_Aceptar_Click()
Dim l1 As Workbook, l2 As Workbook
Dim h1 As Worksheet, h2 As Worksheet, h3 As Worksheet
Dim f As Range, cols As Variant
Dim i As Long, j As Long, k As Long
Dim vCombo as variant
'
Application.ScreenUpdating = False
'
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("ENTRADAS")
Set h3 = l1.Sheets("SALIDAS")
h1.Unprotect "1717171"
h3.Unprotect "1717171"
If h1.AutoFilterMode Then h1.AutoFilterMode = False
If h3.AutoFilterMode Then h3.AutoFilterMode = False
'
'Entradas
if isnumeric(Cmb_CodigoItem) then vcombo = val(Cmb_CodigoItem) else vcombo = Cmb_CodigoItem
Set f = h1.Range("A:A").Find(vcombo, , xlValues, xlWhole, , , False)
If Not f Is Nothing Then
Set l2 = Workbooks.Add 'Adicionar libro nuevo para informe
Set h2 = l2.Sheets(1)
k = 11 'Fila inicial hoja destino
cols = Array(6, 4, 5, 3, 9, 8) 'Columnas donde esta la informacion q debe ir al informe
For i = 1 To h1.Range("A" & Rows.Count).End(3).Row
If h1.Range("A" & i) = vcombo Then
For j = LBound(cols) To UBound(cols)
h1.Range(h1.Cells(i, cols(j)), h1.Cells(i, cols(j))).Copy h2.Cells(k, j + 1)
Next
k = k + 1
End If
Next
End If
'Salidas
Set f = h3.Range("A:A").Find(vcombo, , xlValues, xlWhole, , , False)
If Not f Is Nothing Then
If h2 Is Nothing Then
Set l2 = Workbooks.Add 'Adicionar libro nuevo para informe
Set h2 = l2.Sheets(1)
k = 11
End If
Cols = Array(6, 4, 5, 3, 8, 7) 'Columnas donde esta la informacion q debe ir al informe
For i = 1 To h3.Range("A" & Rows.Count).End(3).Row
If h3.Range("A" & i) = vcombo Then
For j = LBound(cols) To UBound(cols)
h3.Range(h3.Cells(i, cols(j)), h3.Cells(i, cols(j))).Copy h2.Cells(k, j + 1)
Next
k = k + 1
End If
Next
End If
'
If Not h2 Is Nothing Then
h2.Range("A1") = "INFORME MOVIMIENTO POR ITEM"
h2.Range("B3") = Cmb_CodigoItem
h2.Range("B4") = TextBox1
h2.Range("A3") = "CODIGO:"
h2.Range("A4") = "DESCRIPCION:"
h2.Range("A5") = "CATEGORIA:"
h2.Range("A6") = "EXISTENCIA ACTUAL:"
h2.Range("H6") = "<== EXISTENCIA SEGUN MOVIMIENTO:"
End If
'
Application.ScreenUpdating = True
End Sub
Buenas tardes:
El anterior es el vínculo donde está el archivo, al ingresar le solicita usuario y contraseña que son:
Usuario: GTOBAR
Contraseña: CG1005
Una vez ingrese se accede por el boton Reportes y posteriormente MOVIMIENTO POR ITEM, si el proyecto pide contraseña para editar el código es 1005CGgft-*/ para desproteger las hojas la contraseña es 1717171
Para mostrar todas las hojas ocultas se ejecuta una macro con la tecla de acceso L, es decir Ctrl + shift + L
Prueba lo siguiente:
Private Sub Btn_Aceptar_Click()
Dim l1 As Workbook, l2 As Workbook
Dim h1 As Worksheet, h2 As Worksheet, h3 As Worksheet
Dim f As Range, cols As Variant
Dim i As Long, j As Long, k As Long
Dim vCombo As Variant
'
Application.ScreenUpdating = False
'
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("ENTRADAS")
Set h3 = l1.Sheets("SALIDAS")
h1.Unprotect "1717171"
h3.Unprotect "1717171"
If h1.AutoFilterMode Then h1.AutoFilterMode = False
If h3.AutoFilterMode Then h3.AutoFilterMode = False
On Error Resume Next
h1.ShowAllData
h3.ShowAllData
On Error GoTo 0
'
'Entradas
If IsNumeric(Cmb_CodigoItem) Then vCombo = Val(Cmb_CodigoItem) Else vCombo = Cmb_CodigoItem
Set f = h1.Range("A:A").Find(vCombo, , xlValues, xlWhole, , , False)
If Not f Is Nothing Then
Set l2 = Workbooks.Add 'Adicionar libro nuevo para informe
Set h2 = l2.Sheets(1)
k = 11 'Fila inicial hoja destino
cols = Array(6, 4, 5, 3, 9, 8) 'Columnas donde esta la informacion q debe ir al informe
For i = 1 To h1.Range("A" & Rows.Count).End(3).Row
If h1.Range("A" & i) = vCombo Then
For j = LBound(cols) To UBound(cols)
h1.Range(h1.Cells(i, cols(j)), h1.Cells(i, cols(j))).Copy h2.Cells(k, j + 8)
Next
k = k + 1
End If
Next
End If
'Salidas
Set f = h3.Range("A:A").Find(vCombo, , xlValues, xlWhole, , , False)
If Not f Is Nothing Then
k = 11
If h2 Is Nothing Then
Set l2 = Workbooks.Add 'Adicionar libro nuevo para informe
Set h2 = l2.Sheets(1)
End If
cols = Array(6, 4, 5, 3, 8, 7) 'Columnas donde esta la informacion q debe ir al informe
For i = 1 To h3.Range("A" & Rows.Count).End(3).Row
If h3.Range("A" & i) = vCombo Then
For j = LBound(cols) To UBound(cols)
h3.Range(h3.Cells(i, cols(j)), h3.Cells(i, cols(j))).Copy h2.Cells(k, j + 2)
Next
k = k + 1
End If
Next
End If
'
If Not h2 Is Nothing Then
h2.Range("A1") = "INFORME MOVIMIENTO POR ITEM"
h2.Range("B3") = Cmb_CodigoItem
h2.Range("B4") = TextBox1
h2.Range("A3") = "CODIGO:"
h2.Range("A4") = "DESCRIPCION:"
h2.Range("A5") = "CATEGORIA:"
h2.Range("A6") = "EXISTENCIA ACTUAL:"
h2.Range("H6") = "<== EXISTENCIA SEGUN MOVIMIENTO:"
End If
'
' Application.ScreenUpdating = True
'End Sub
'Hasta aqui el código que me envio el dia 31 de agosto de 2020
'*******************************************
Me genera la información de entradas y salidas de forma contraria, pero ya encontré el error y lo corregí, estaba en que al copiar la información de entradas le sumaba 8 columnas y en salidas 2, es al contrario, hice ese cambio y me funciona para la generación del reporte, pero ahora me surgió otro inconveniente, cuando no hay información para generar el reporte, me sale un error al llamar la macro para dar formatos al reporte, y pues entiendo que es porque no se adiciona el libro nuevo (Ej. al generar el reporte para item 2), existe la posibilidad de que me pueda colaborar con ese tema?, si es necesario colocar otra consulta lo hago.
De antemano y nuevamente muchas gracias por su paciencia y su espiritu de colaboración.
Me alegra ayudarte, no o l v i d e s valorar la respuesta y ¡Gracias! Por comentar.
Crea una nueva pregunta.
