asked on

vba to perform filters within a looped sequence

Having had EE help to enable my example to loop through a list of actionable sheets, I have the challenge of now being asked to insert 3 types of filter for every sheet opened in the loop.
For me the difficulty is whilst I can code the individual filters - I cannot grasp the VBA semantics of how they are incorporated into the loop
Any help would be appreciated
Test-1.xlsm

Martin Liss

Are you talking about something like this? (See l.ine 27)

Sub CopyDataToSummary()
Dim ws As Worksheet, dws As Worksheet, admWs As Worksheet
Dim lr As Long, alr As Long, i As Long, dlr As Long
Dim x
Application.ScreenUpdating = False
Set dws = Sheets("percent upload")
Set admWs = Sheets("Admin")
'dws.Cells.Clear
dws.Range("A1:F1").Value = Array("", "Branch", "Line", "", "", "Override")
alr = admWs.Cells(Rows.Count, 2).End(xlUp).Row
If alr < 6 Then
   MsgBox "There are no sheets listed on Admin Sheet.", vbExclamation, "Sheet List Not Found!"
   Exit Sub
End If
x = admWs.Range("B5:B" & alr).Value
For i = 1 To UBound(x, 1)
   On Error Resume Next
   Set ws = Sheets(x(i, 1))
   If Not ws Is Nothing Then
      lr = ws.Cells(Rows.Count, 22).End(xlUp).Row
      If lr > 5 Then
         ws.Range("V6:Z" & lr).Copy
         dws.Range("B" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
         Application.CutCopyMode = 0
      End If
      '
      ' Do something else here???
      '
   End If
Next i
'dws.Range("C5").CurrentRegion.Borders.Color = vbBlack
Application.ScreenUpdating = True
MsgBox "Data has been copied to Summary Sheet successfully.", vbInformation, "Done!"
End Sub

Open in new window

DAVID131

ASKER

Good Morning Martin
Thanks for the response
I have tried to amend the code to carry out actions 2 and 3 in the admin sheet but have been unsuccessful.
Could you advise on what I am doing wrong - and I will try again
Test-1.01.xlsm

Martin Liss

What value are you trying to retrieve in line 15, and what are you attempting to do in line 16? (I indented some of your code to make it easier to read.)

Sub CopyDataToSummary()
Dim ws As Worksheet, dws As Worksheet, admWs As Worksheet
Dim lr As Long, alr As Long, i As Long, dlr As Long
Dim x
Application.ScreenUpdating = False
Set dws = Sheets("percent upload")
Set admWs = Sheets("Admin")
'dws.Cells.Clear
dws.Range("A1:F1").Value = Array("", "Branch", "Line", "", "", "Override")
alr = admWs.Cells(Rows.Count, 2).End(xlUp).Row
If alr < 6 Then
   MsgBox "There are no sheets listed on Admin Sheet.", vbExclamation, "Sheet List Not Found!"
   Exit Sub
End If
x = admWs.Range("B5:B" & alr).Value
For i = 1 To UBound(x, 1)
   On Error Resume Next
   Set ws = Sheets(x(i, 1))
   If Not ws Is Nothing Then
      lr = ws.Cells(Rows.Count, 22).End(xlUp).Row
      If lr > 5 Then
         'ws.Range("V6:Z" & lr).Copy
         'dws.Range("B" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
         'Application.CutCopyMode = 0
         If ActiveSheet.AutoFilterMode = True Then
            Selection.AutoFilter
         End If
         XROW = Range("v999999").End(xlUp).Row
         ws.Range("v6").Select
         Selection.AutoFilter
         ActiveSheet.Range("$V$6:$Z" & XROW).AutoFilter Field:=1, Criteria1:=">=1"
         Set filteredrange = ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
         For Each rngrow In filteredrange.Rows
            lastrow = rngrow.Row
            Firstrow = rngrow.Row
        
         Next
         ws.Range("V" & Firstrow & "z" & lastrow).Select
         Selection.Copy
         Sheets("percent upload").Select
         If Range("B2").Value = "" Then
            Range("B2").Select
         Else
            Range("B1").End(xlDown).Select
         End If
         Selection.Paste.Special Paste:=xlPasteValues
         Application.CutCopyMode = False
        
         
      End If
      
     
   End If
Next i
'dws.Range("C5").CurrentRegion.Borders.Color = vbBlack
Application.ScreenUpdating = True
MsgBox "Data has been copied to Summary Sheet successfully.", vbInformation, "Done!"
End Sub

Open in new window

DAVID131

ASKER

Good Morning Martin
Lines 15 and 16 were part of the original code that worked very well, therefore I left them in as they appeared to be part of the instruction to loop through the admin list of sheets with content to be copied.
Whereas the original code copied semi-fixed cells what I am trying to do is insert code that filters those semi-fixed cells and copies the resulting values into the percent upload within the loop that reads the list of sheets in the admin sheet.
I am trying to learn from this so any explanations would be appreciated

DAVID131

ASKER

Martin
In the attached I have written the code for the 3 filters that I need to be enacted within the original loop code, however I have two problems
1. How do I incorporate the filter codes (which work) within the admin looping code (which works)
2. The third filter requires the paste value to be repeated 3 times but I am getting run time error 1004
EE-Test-2.xlsm

Martin Liss

OK, if you change the test_filter sub so that it looks like this, where I've replaced "sheet 05" with a variable...

Sub test_filter(ws As Worksheet)
'
' test_filter Macro
'
' perform first filter
'
    Sheets(ws).Select
    If ActiveSheet.AutoFilterMode = True Then
    Selection.AutoFilter
    End If
    
    xrow = Range("V999999").End(xlUp).Row
    
    Range("V5").Select
    Selection.AutoFilter
    ActiveSheet.Range("$V$5:$z$" & xrow).AutoFilter field:=1, Criteria1:="<700", Operator:=xlAnd
    
    Set filteredrange = ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
    
    headerrow = ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas(1).Row
    flag = 0
    For Each rngrow In filteredrange.Rows
    lastrow = rngrow.Row
    If rngrow.Hidden = False And rngrow.Row <> headerrow And flag = 0 Then
    flag = 1
    firstrow = rngrow.Row
    End If
    Next
    If firstrow > 0 Then
    Range("V" & firstrow & ":Z" & lastrow).Select
    Selection.Copy
    Sheets("percent upload 2").Select
    If Range("B2").Value = "" Then
    Range("B2").Select
    Else
    Range("B1").End(xlDown).Offset(1, 0).Select
    End If
    
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("H1").Select
    
   'perform second filter
   
    End If
    
  Sheets(ws).Select
    If ActiveSheet.AutoFilterMode = True Then
    Selection.AutoFilter
    End If
    
    xrow = Range("AA999999").End(xlUp).Row
    
    Range("AA5").Select
    Selection.AutoFilter
    ActiveSheet.Range("$AA$5:$AE$" & xrow).AutoFilter field:=2, Criteria1:=">1", Operator:=xlAnd
    
    Set filteredrange = ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
    
    headerrow = ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas(1).Row
    flag = 0
    For Each rngrow In filteredrange.Rows
    lastrow = rngrow.Row
    If rngrow.Hidden = False And rngrow.Row <> headerrow And flag = 0 Then
    flag = 1
    firstrow = rngrow.Row
    End If
    Next
    If firstrow > 0 Then
    Range("AA" & firstrow & ":AE" & lastrow).Select
    Selection.Copy
    Sheets("percent upload 2").Select
    If Range("B2").Value = "" Then
    Range("B2").Select
    Else
    Range("B1").End(xlDown).Offset(1, 0).Select
    End If
    
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("H1").Select
    End If
    
    'perform 3rd filter multiple times
    
    
    Sheets(ws).Select
    If ActiveSheet.AutoFilterMode = True Then
    Selection.AutoFilter
    End If
    
    xrow = Range("N999999").End(xlUp).Row
    
    Range("N5").Select
    Selection.AutoFilter
    ActiveSheet.Range("$N$5:$O$" & xrow).AutoFilter field:=1, Criteria1:=">1", Operator:=xlAnd
    
    Set filteredrange = ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
    
    headerrow = ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas(1).Row
    flag = 0
    For Each rngrow In filteredrange.Rows
    lastrow = rngrow.Row
    If rngrow.Hidden = False And rngrow.Row <> headerrow And flag = 0 Then
    flag = 1
    firstrow = rngrow.Row
    End If
    Next
    
    
    If firstrow > 0 Then
    Range("N" & firstrow & ":O" & lastrow).Select
    Selection.Copy
    Sheets("value upload 2").Select
    If Range("A2").Value = "" Then
    Range("A2").Select
    Else
   
    Range("A1").End(xlDown).Offset(1, 0).Select
    End If
    For J = 1 To 3 'THIS PRODUCES ERROR WARNING - Error warning 1004 PASTE SPECIAL METHOD OF RANGE CLASS FAILED
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
   Next J
    Range("H1").Select
    End If
    

    
End Sub

Open in new window

...you can call it from the loop as I've done at line 21 (although I don't fully understand what you need so I don't know if that's the right place).

Sub CopyDataToSummary()
Dim ws As Worksheet, dws As Worksheet, admWs As Worksheet
Dim lr As Long, alr As Long, i As Long, dlr As Long
Dim x
Application.ScreenUpdating = False
Set dws = Sheets("percent upload")
Set admWs = Sheets("Admin")
'dws.Cells.Clear
dws.Range("A1:F1").Value = Array("", "Branch", "Line", "", "", "Override")
alr = admWs.Cells(Rows.Count, 2).End(xlUp).Row
If alr < 6 Then
   MsgBox "There are no sheets listed on Admin Sheet.", vbExclamation, "Sheet List Not Found!"
   Exit Sub
End If
x = admWs.Range("B5:B" & alr).Value
For i = 1 To UBound(x, 1)
   On Error Resume Next
   Set ws = Sheets(x(i, 1))
   If Not ws Is Nothing Then
   
      test_filter Sheets(ws)

      lr = ws.Cells(Rows.Count, 22).End(xlUp).Row
      If lr > 5 Then
         ws.Range("V6:Z" & lr).Copy
         dws.Range("B" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
         Application.CutCopyMode = 0
      End If
   End If
Next i
'dws.Range("C5").CurrentRegion.Borders.Color = vbBlack
Application.ScreenUpdating = True
MsgBox "Data has been copied to Summary Sheet successfully.", vbInformation, "Done!"
End Sub

Open in new window

DAVID131

ASKER

Good Afternoon Martin
I feel we are so close to cracking this.
I have attached two workbooks
EE4.00 with the stand alone macros all working ok
EE4.01 with the primary macro looping through a list of sheets and calling up the new (routine - not sure of my semantics ?) which whilst producing no errors does not produce any values

Along the journey I have resolved the 3rd filter performing multiple copies by using a Do While loop

I have never used a sub with the parentheses populated and may have done something stupid
Could you advise on what I have done wrong
Thanks
EE-4.00----3-Filters-1-sheet-ok-.xlsm
EE-4.01----Combined-not-ok.xlsm

ASKER CERTIFIED SOLUTION

Martin Liss

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

DAVID131

ASKER

Martin
the code worked a treat with the only issue being that where the filter produced no results the macro brought through the header - how do I best trap that out?
109      45
109      45
Branch      Line
Branch      Line
Branch      Line
Branch      Line
Branch      Line
Branch      Line
Branch      Line
117      30
151      25

Martin Liss

Make the change at line 118 as shown. Have you noticed the repeating 117, 151, 172 sets in the "value upload 2" sheet? Is that desired?

Sub Three_filters(ws As Worksheet)
'
' three_filters Macro
'
' perform first filter
'
    ws.Select

    If ActiveSheet.AutoFilterMode = True Then
    Selection.AutoFilter
    End If
    
    xrow = Range("V999999").End(xlUp).Row
    
    Range("V5").Select
    Selection.AutoFilter
    ActiveSheet.Range("$V$5:$z$" & xrow).AutoFilter field:=1, Criteria1:=">1", Operator:=xlAnd
    
    Set filteredrange = ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
    
    headerrow = ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas(1).Row
    flag = 0
    For Each rngrow In filteredrange.Rows
    lastrow = rngrow.Row
    If rngrow.Hidden = False And rngrow.Row <> headerrow And flag = 0 Then
    flag = 1
    firstrow = rngrow.Row
    End If
    Next
    If firstrow > 0 Then
    Range("V" & firstrow & ":Z" & lastrow).Select
    Selection.Copy
    Sheets("percent upload 2").Select
    If Range("B2").Value = "" Then
    Range("B2").Select
    Else
    Range("B1").End(xlDown).Offset(1, 0).Select
    End If
    
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("H1").Select
   
    End If
    
    'perform second filter
    
    ws.Select
    
    If ActiveSheet.AutoFilterMode = True Then
    Selection.AutoFilter
    End If
    
    xrow = Range("AA999999").End(xlUp).Row
    
    Range("AA5").Select
    Selection.AutoFilter
    ActiveSheet.Range("$AA$5:$AE$" & xrow).AutoFilter field:=2, Criteria1:=">1", Operator:=xlAnd
    
    Set filteredrange = ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
    
    headerrow = ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas(1).Row
    flag = 0
    For Each rngrow In filteredrange.Rows
    lastrow = rngrow.Row
    If rngrow.Hidden = False And rngrow.Row <> headerrow And flag = 0 Then
    flag = 1
    firstrow = rngrow.Row
    End If
    Next
    If firstrow > 0 Then
    Range("AA" & firstrow & ":AE" & lastrow).Select
    Selection.Copy
    Sheets("percent upload 2").Select
    If Range("B2").Value = "" Then
    Range("B2").Select
    Else
    Range("B1").End(xlDown).Offset(1, 0).Select
    End If
    
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("H1").Select
    End If
    
    'perform 3rd filter multiple times
    
    Dim x
    
    ws.Select
    
    If ActiveSheet.AutoFilterMode = True Then
    Selection.AutoFilter
    End If
    
    xrow = Range("N999999").End(xlUp).Row
    
    Range("N5").Select
    Selection.AutoFilter
    ActiveSheet.Range("$N$5:$O$" & xrow).AutoFilter field:=1, Criteria1:=">1", Operator:=xlAnd
    
    Set filteredrange = ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
    
    headerrow = ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas(1).Row
    flag = 0
    For Each rngrow In filteredrange.Rows
    lastrow = rngrow.Row
    If rngrow.Hidden = False And rngrow.Row <> headerrow And flag = 0 Then
    flag = 1
    firstrow = rngrow.Row
    End If
    Next
    
    '******* New Start *******
'    If firstrow > 0 Then
    If firstrow > 0 And ws.Cells(firstrow, "N") <> "" Then
    '******* New End *********

    Range("N" & firstrow & ":O" & lastrow).Select
    
    Let x = 0
    Do While x < 7
    
    Selection.Copy
    Sheets("value upload 2").Select
    If Range("A2").Value = "" Then
    Range("A2").Select
    Else
   
    Range("A1").End(xlDown).Offset(1, 0).Select
    End If
    
    
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    
    x = x + 1
    Loop
    
    Range("H1").Select
    End If
    

    
End Sub

Open in new window

Martin Liss

I'm glad I was able to help.

In my profile you'll find links to some additional articles I've written that may interest you.

Marty - Microsoft MVP 2009 to 2016
Experts Exchange MVE 2015
Experts Exchange Top Expert Visual Basic Classic 2012 to 2015