Macro de búsqueda y filtro de información en varias hojas
Hace mucho tiempo me enviaste una macro que me ha ayudado muchísimo. Al día de hoy comenzó a fallar y presentar en error que me pide depurar. ¿Podrías ayudarme de nueva cuenta?
1 respuesta
H o l a:
Pon la macro que tiene el problema.
Dime qué mensaje de error te aparece.
Cuando te aparece el mensaje de depurar, presiona el botón de depurar y dime qué línea de la macro se pone de amarillo.
sal u dos
Ese es el error que me da el 1004. Te envío la macro
Public campo1, campo2
Private Sub Image2_Click()
UserForm2.Show
End Sub
Private Sub ListBox1_Click()
End Sub
Private Sub TextBox1_Change()
If IsNumeric(TextBox1) Then
campo1 = Me.TextBox1.Value
Else
campo1 = Me.TextBox1.Text & IIf(Me.TextBox1.Text = "", "", "*")
End If
filtrar
End Sub
Private Sub TextBox2_Change()
If IsNumeric(TextBox2) Then
campo2 = Me.TextBox2.Value
Else
campo2 = Me.TextBox2.Text & IIf(Me.TextBox2.Text = "", "", "*")
End If
filtrar
End Sub
Sub filtrar()
Application.ScreenUpdating = False
ActiveWorkbook.Worksheets("filtro").Visible = True
Sheets("filtro").Cells.Clear
For i = 2 To 28
With Sheets(i)
With .Range("A5:F" & .Range("A" & Rows.Count).End(xlUp).Row)
If campo1 <> "" Or campo2 <> "" Then
If campo1 <> "" Then .AutoFilter Field:=2, Criteria1:=campo1
If campo2 <> "" Then .AutoFilter Field:=4, Criteria1:=campo2
.Copy Sheets("filtro").Range("A1")
Else
Sheets("filtro").Cells.Clear
Me.ListBox1 = ""
End If
End With
If .AutoFilterMode Then .Range("A1").AutoFilter
End With
With Sheets("filtro")
uf = .Range("A" & .Rows.Count).End(xlUp).Row
If uf < 2 Then uf = 2
.Columns("A:F").EntireColumn.AutoFit
ancho = Int(.Range("A1").Width + 5) & ";" & Int(.Range("B1").Width + 5) & ";" & _
Int(.Range("C1").Width + 5) & ";" & Int(.Range("D1").Width + 5) & ";" & _
Int(.Range("E1").Width + 5) & ";" & Int(.Range("D1").Width + 5)
tot = Application.Sum(.Range(.Cells(2, "F"), .Cells(uf, "F")))
End With
'uf = Sheets("filtro").Range("A" & Rows.Count).End(xlUp).Row
With Me.ListBox1
.RowSource = ""
.ColumnCount = 6
.RowSource = "filtro!A2:F" & uf
.ColumnHeads = True
.ColumnWidths = ancho
End With
TextBox3 = Format(tot, "$ #,##0.00")
Next i
ActiveWorkbook.Worksheets("filtro").Visible = xlVeryHidden
Application.ScreenUpdating = True
End Sub
Public campo1, campo2 Private Sub Image2_Click() UserForm2.Show End Sub Private Sub ListBox1_Click() End Sub Private Sub TextBox1_Change() If IsNumeric(TextBox1) Then campo1 = Me.TextBox1.Value Else campo1 = Me.TextBox1.Text & IIf(Me.TextBox1.Text = "", "", "*") End If filtrar End Sub Private Sub TextBox2_Change() If IsNumeric(TextBox2) Then campo2 = Me.TextBox2.Value Else campo2 = Me.TextBox2.Text & IIf(Me.TextBox2.Text = "", "", "*") End If filtrar End Sub Sub filtrar() Application.ScreenUpdating = False ActiveWorkbook.Worksheets("filtro").Visible = True Sheets("filtro").Cells.Clear For i = 2 To 28 With Sheets(i) With .Range("A5:F" & .Range("A" & Rows.Count).End(xlUp).Row) If campo1 <> "" Or campo2 <> "" Then If campo1 <> "" Then .AutoFilter Field:=2, Criteria1:=campo1 If campo2 <> "" Then .AutoFilter Field:=4, Criteria1:=campo2 .Copy Sheets("filtro").Range("A1") Else Sheets("filtro").Cells.Clear Me.ListBox1 = "" End If End With If .AutoFilterMode Then .Range("A1").AutoFilter End With With Sheets("filtro") uf = .Range("A" & .Rows.Count).End(xlUp).Row If uf < 2 Then uf = 2 .Columns("A:F").EntireColumn.AutoFit ancho = Int(.Range("A1").Width + 5) & ";" & Int(.Range("B1").Width + 5) & ";" & _ Int(.Range("C1").Width + 5) & ";" & Int(.Range("D1").Width + 5) & ";" & _ Int(.Range("E1").Width + 5) & ";" & Int(.Range("D1").Width + 5) tot = Application.Sum(.Range(.Cells(2, "F"), .Cells(uf, "F"))) End With 'uf = Sheets("filtro").Range("A" & Rows.Count).End(xlUp).Row With Me.ListBox1 .RowSource = "" .ColumnCount = 6 .RowSource = "filtro!A2:F" & uf .ColumnHeads = True .ColumnWidths = ancho End With TextBox3 = Format(tot, "$ #,##0.00") Next i ActiveWorkbook.Worksheets("filtro").Visible = xlVeryHidden Application.ScreenUpdating = True End Sub
El error aparece aquí,
¿Cambiaste la hoja "filtro" de lugar?
Pon la hoja "filtro" hasta el final de las hojas.
Revisa que tengas hojas para aplicar el filtro desde la 2 hasta la 28, si tienes menos hojas deberás cambiar el 28 por el número de hojas:
For i = 2 To 28
Ya cambie la hoja de filtro al final (me gustaría que estuviera en la segunda hoja), pero cada vez que busco me muestra la misma persona no importa el RFC o el nombre de la persona que ponga siempre me muestra la misma y ni si quiera me muestra el monto de suma
Esta es la macro, no revisa el número de hojas y puedes poner la hoja filtro en segundo lugar.
Public campo1, campo2 Private Sub ComboBox1_Change() 'Por.DAM TextBox1 = "" TextBox2 = "" End Sub Private Sub CommandButton1_Click() 'Por.DAM If OptionButton1 = False And OptionButton2 = False Then MsgBox "Selecciona una opción", vbExclamation Exit Sub End If If OptionButton2 Then Exit Sub If IsNumeric(TextBox1) Then campo1 = Me.TextBox1.Value Else campo1 = Me.TextBox1.Text & IIf(Me.TextBox1.Text = "", "", "*") End If If IsNumeric(TextBox2) Then campo2 = Me.TextBox2.Value Else campo2 = Me.TextBox2.Text & IIf(Me.TextBox2.Text = "", "", "*") End If filtrar End Sub Private Sub OptionButton1_Click() 'Por.DAM ComboBox1.Clear TextBox1 = "" TextBox2 = "" ListBox1 = "" Sheets("filtro").Cells.Clear End Sub Private Sub OptionButton2_Click() 'Por.DAM For Each h In Worksheets Select Case h.Name Case "Hoja1", "filtro" Case Else: ComboBox1.AddItem h.Name End Select Next TextBox1 = "" TextBox2 = "" ListBox1 = "" Sheets("filtro").Cells.Clear End Sub Private Sub TextBox1_Change() 'Por.DAM If OptionButton2 And ComboBox1 <> "" Then If IsNumeric(TextBox1) Then campo1 = Me.TextBox1.Value Else campo1 = Me.TextBox1.Text & IIf(Me.TextBox1.Text = "", "", "*") End If filtrar End If End Sub Private Sub TextBox2_Change() 'Por.DAM If OptionButton2 And ComboBox1 <> "" Then If IsNumeric(TextBox2) Then campo2 = Me.TextBox2.Value Else campo2 = Me.TextBox2.Text & IIf(Me.TextBox2.Text = "", "", "*") End If filtrar End If End Sub Sub filtrar() 'Por.DAM Application.ScreenUpdating = False Sheets("filtro").Cells.Clear 'copia los títulos Label4.Caption = "Procesando ..." DoEvents Sheets("CAM GOB").Rows(4).EntireRow.Copy Sheets("filtro").Range("A1") If OptionButton1 Then For Each h In Worksheets Select Case h.Name Case "Hoja1", "filtro" Case Else subfiltro (h.Name) End Select Next ElseIf OptionButton2 Then subfiltro (ComboBox1) End If With Sheets("filtro") uf = .Range("A" & .Rows.Count).End(xlUp).Row If uf < 2 Then uf = 2 .Columns("A:F").EntireColumn.AutoFit ancho = Int(.Range("A1").Width + 5) & ";" & Int(.Range("B1").Width + 5) & ";" & _ Int(.Range("C1").Width + 5) & ";" & Int(.Range("D1").Width + 5) & ";" & _ Int(.Range("E1").Width + 5) & ";" & Int(.Range("D1").Width + 5) tot = Application.Sum(.Range(.Cells(2, "F"), .Cells(uf, "F"))) End With With Me.ListBox1 .RowSource = "" .ColumnCount = 6 .RowSource = "filtro!A2:F" & uf .ColumnHeads = True .ColumnWidths = ancho End With TextBox3 = Format(tot, "$ #,##0.00") Label4.Caption = "" DoEvents Application.ScreenUpdating = True End Sub Sub subfiltro(hoja) 'Por.DAM lahoja = hoja With Sheets(hoja) With .Range("A4:F" & .Range("A" & Rows.Count).End(xlUp).Row) If campo1 <> "" Or campo2 <> "" Then If campo1 <> "" Then .AutoFilter Field:=2, Criteria1:=campo1 If campo2 <> "" Then .AutoFilter Field:=4, Criteria1:=campo2 uff = Sheets("filtro").Range("A" & .Rows.Count).End(xlUp).Row + 1 uf2 = Sheets(hoja).Range("A" & .Rows.Count).End(xlUp).Row If uf2 > 4 Then Sheets(hoja).Range("A5:F" & Sheets(hoja). _ Range("A" & Rows.Count).End(xlUp).Row).Copy _ Sheets("filtro").Range("A" & uff) End If End If End With If .AutoFilterMode Then .Range("A1").AutoFilter End With End Sub Private Sub ComboBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) 'Para no capturar nada en el combobox KeyAscii = 0 End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
Te anexo la macro actualizada
Public campo1, campo2 Private Sub ComboBox1_Change() 'Por.DAM TextBox1 = "" TextBox2 = "" End Sub Private Sub CommandButton1_Click() 'Por.DAM If OptionButton1 = False And OptionButton2 = False Then MsgBox "Selecciona una opción", vbExclamation Exit Sub End If If OptionButton2 Then Exit Sub If IsNumeric(TextBox1) Then campo1 = Me.TextBox1.Value Else campo1 = Me.TextBox1.Text & IIf(Me.TextBox1.Text = "", "", "*") End If If IsNumeric(TextBox2) Then campo2 = Me.TextBox2.Value Else campo2 = Me.TextBox2.Text & IIf(Me.TextBox2.Text = "", "", "*") End If filtrar End Sub Private Sub OptionButton1_Click() 'Por.DAM ComboBox1.Clear TextBox1 = "" TextBox2 = "" ListBox1 = "" Sheets("filtro").Cells.Clear End Sub Private Sub OptionButton2_Click() 'Por.DAM For Each h In Worksheets Select Case h.Name Case "Hoja1", "filtro" Case Else: ComboBox1.AddItem h.Name End Select Next TextBox1 = "" TextBox2 = "" ListBox1 = "" Sheets("filtro").Cells.Clear End Sub Private Sub TextBox1_Change() 'Por.DAM If OptionButton2 And ComboBox1 <> "" Then If IsNumeric(TextBox1) Then campo1 = Me.TextBox1.Value Else campo1 = Me.TextBox1.Text & IIf(Me.TextBox1.Text = "", "", "*") End If filtrar End If End Sub Private Sub TextBox2_Change() 'Por.DAM If OptionButton2 And ComboBox1 <> "" Then If IsNumeric(TextBox2) Then campo2 = Me.TextBox2.Value Else campo2 = Me.TextBox2.Text & IIf(Me.TextBox2.Text = "", "", "*") End If filtrar End If End Sub Sub filtrar() 'Por.DAM Application.ScreenUpdating = False Sheets("filtro").Cells.Clear 'copia los títulos Label4.Caption = "Procesando ..." DoEvents Sheets(3).Rows(4).Copy Sheets("filtro").Range("A1") If OptionButton1 Then For Each h In Worksheets Select Case h.Name Case "Hoja1", "filtro" Case Else subfiltro (h.Name) End Select Next ElseIf OptionButton2 Then subfiltro (ComboBox1) End If With Sheets("filtro") uf = .Range("A" & .Rows.Count).End(xlUp).Row If uf < 2 Then uf = 2 .Columns("A:G").EntireColumn.AutoFit ancho = Int(.Range("A1").Width + 5) & ";" & Int(.Range("B1").Width + 5) & ";" & _ Int(.Range("C1").Width + 5) & ";" & Int(.Range("D1").Width + 5) & ";" & _ Int(.Range("E1").Width + 5) & ";" & Int(.Range("F1").Width + 5) & ";" & _ Int(.Range("G1").Width + 5) tot = Application.Sum(.Range(.Cells(2, "G"), .Cells(uf, "G"))) End With With Me.ListBox1 .RowSource = "" .ColumnCount = 8 .RowSource = "filtro!A2:G" & uf .ColumnHeads = True .ColumnWidths = ancho End With TextBox3 = Format(tot, "$ #,##0.00") Label4.Caption = "" DoEvents Application.ScreenUpdating = True End Sub Sub subfiltro(hoja) 'Por.DAM lahoja = hoja For i = 5 To Sheets(hoja).Range("A" & Rows.Count).End(xlUp).Row If TextBox2 = "" Then año = Sheets(hoja).Cells(i, "E") Else año = Val(TextBox2) If UCase(Sheets(hoja).Cells(i, "A") & Sheets(hoja).Cells(i, "B") & Sheets(hoja).Cells(i, "C")) _ Like "*" & UCase(TextBox1) & "*" And Sheets(hoja).Cells(i, "E") = año Then uff = Sheets("filtro").Range("A" & Rows.Count).End(xlUp).Row + 1 Sheets(hoja).Rows(i).Copy Sheets("filtro").Range("A" & uff) End If Next ' With Sheets(hoja) ' With .Range("A4:F" & .Range("A" & Rows.Count).End(xlUp).Row) ' If campo1 <> "" Or campo2 <> "" Then ' If campo1 <> "" Then .AutoFilter Field:=2, Criteria1:=campo1 ' If campo2 <> "" Then .AutoFilter Field:=4, Criteria1:=campo2 ' uff = Sheets("filtro").Range("A" & .Rows.Count).End(xlUp).Row + 1 ' uf2 = Sheets(hoja).Range("A" & .Rows.Count).End(xlUp).Row ' If uf2 > 4 Then ' Sheets(hoja).Range("A5:F" & Sheets(hoja). _ ' Range("A" & Rows.Count).End(xlUp).Row).Copy _ ' Sheets("filtro").Range("A" & uff) ' End If ' End If ' End With ' If .AutoFilterMode Then .Range("A1").AutoFilter ' End With End Sub Private Sub ComboBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) 'Para no capturar nada en el combobox KeyAscii = 0 End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
- Compartir respuesta