Loop through filtered column

[antrixx]

Hi all,

I have a simple table which I use the following code to filter and print preview data:

Sub FilterAndPrintPreview()

ActiveSheet.ListObjects("Table2").Range.AutoFilter Field:=17, Criteria1:= _
"Open"
ActiveSheet.ListObjects("Table2").Range.AutoFilter Field:=4, Criteria1:=Cells(2, 4)

With ActiveSheet
.PageSetup.PrintArea = .Range("$A$3:I" & .Range("A" & Rows.Count).End(xlUp).Row).Address
.PrintPreview
End With

End Sub

This code filters column Q (column 17) for all cases marked as 'Open'.
Column D (column 4) is filtered to match the user, which is located in cell D2.

The above code works perfectly for my needs, but only for 1 person at a time. It will print preview the open cases for each user, allowing me to then print that information.

What I'm looking to do, is to be able to print preview all of the cases marked as 'Open', but for all of the options in the dropdown box located in D2 on separate pages, excluding any users where there are no rows marked as 'Open' for them.

e.g. If there were 10 people in total, and 4 people have 'Open' cases, it would print preview 4 pages, with each page showing the 'Open' cases for those users.

Is there a way to filter all of the users in 1 macro, and have them print preview on their own page in 1 go?

I hope that makes sense.

 

[John_w]

Try this macro. It works by adding a sheet named "Print", filtering the table for each dropdown (data validation) value and copying the rows to the "Print" sheet, with a page break between each set of rows.

Public Sub AutoFilter_Print_Preview_All_Pages()

    Dim dataSheet As Worksheet, printCells As Range
    Dim table As ListObject
    Dim dataValidationCell As Range, dataValidationListCell As Range
    Dim printSheet As Worksheet, destCell As Range
    
    Application.ScreenUpdating = False
    
    With ActiveWorkbook
        Set dataSheet = .ActiveSheet
        On Error Resume Next
        Set printSheet = .Worksheets("Print")
        On Error GoTo 0
        If printSheet Is Nothing Then
            Set printSheet = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
            printSheet.Name = "Print"
        Else
            printSheet.Cells.Delete
        End If
        Set destCell = printSheet.Range("A1")
    End With
    
    With dataSheet
    
        Set table = .ListObjects("Table2")
        
        'Cell D2 contains the Data validation
        
        Set dataValidationCell = .Range("D2")
     
        'Loop through Data validation list cells
     
        For Each dataValidationListCell In Evaluate(dataValidationCell.Validation.Formula1)
        
            'Change data validation cell value and filter table
            
            dataValidationCell.Value = dataValidationListCell.Value               
            table.Range.AutoFilter Field:=17, Criteria1:="Open"
            table.Range.AutoFilter Field:=4, Criteria1:=dataValidationCell.Value
           
            'Copy cells to temporary print sheet
                
            Set printCells = .Range("A3:I" & .Range("A" & .Rows.Count).End(xlUp).Row)
            printCells.Copy
            destCell.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            destCell.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            destCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            'Use Format Painter to copy and paste row heights
            printCells.EntireRow.Copy
            destCell.Resize(printCells.Rows.Count).EntireRow.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Application.CutCopyMode = False
            
            'Add page break and update destination cell
            
            With printSheet
                .HPageBreaks.Add Before:=.Rows(.UsedRange.Rows.Count + 1)
                Set destCell = .Cells(.UsedRange.Rows.Count + 1, 1)
            End With
            
        Next

        'Remove autofilter
        
        table.Range.AutoFilter
        .Activate
        
    End With
        
    Application.ScreenUpdating = True
    
    printSheet.PrintPreview
    
End Sub

 

[antrixx]

Thanks for the code, it's pretty much there, but a couple of things if you're able to help any further?

In my example of 10 people with 4 open cases, your code will have 10 pages to print. 4 of them have data, and the other 6 would just have the header. Is there a way to just print preview the 4 pages with data?

The second issue is that the main page has a filter along the headers. After running the code, these filters disappear. Is there a way to have the code run whilst still keeping the filtered columns on the main page?

Many thanks.

 

[John_w]

In my example of 10 people with 4 open cases, your code will have 10 pages to print. 4 of them have data, and the other 6 would just have the header. Is there a way to just print preview the 4 pages with data?

This part of my code should do exactly the same as your AutoFilter:

            table.Range.AutoFilter Field:=17, Criteria1:="Open"
            table.Range.AutoFilter Field:=4, Criteria1:=dataValidationCell.Value

That is, filter column Q for "Open" cases and filter column D for the current user in cell D2. Is it not filtering like this?

The second issue is that the main page has a filter along the headers. After running the code, these filters disappear. Is there a way to have the code run whilst still keeping the filtered columns on the main page?

Well the code needs to do its own filtering, so it will lose any existing filters. I've previously written some code that saves and restores autofilter settings, so I'll try and find it and incorporate it into this macro.

 

[Peter_SSs]

In my example of 10 people with 4 open cases, your code will have 10 pages to print. 4 of them have data, and the other 6 would just have the header. Is there a way to just print preview the 4 pages with data?

I would suggest adding these two red lines of code into this section of John's code to see if that fixes this issue for you.

For Each dataValidationListCell In Evaluate(dataValidationCell.Validation.Formula1)

    'Change data validation cell value and filter table
    
    dataValidationCell.Value = dataValidationListCell.Value
    table.Range.AutoFilter Field:=17, Criteria1:="Open"
    table.Range.AutoFilter Field:=4, Criteria1:=dataValidationCell.Value
   
    'Copy cells to temporary print sheet
        
    Set printCells = .Range("A3:I" & .Range("A" & .Rows.Count).End(xlUp).Row)
    If printCells.Columns(1).SpecialCells(xlVisible).Count > 1 Then
      printCells.Copy
      destCell.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      destCell.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      destCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      'Use Format Painter to copy and paste row heights
      printCells.EntireRow.Copy
      destCell.Resize(printCells.Rows.Count).EntireRow.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      Application.CutCopyMode = False
      
      'Add page break and update destination cell
      
      With printSheet
          .HPageBreaks.Add Before:=.Rows(.UsedRange.Rows.Count + 1)
          Set destCell = .Cells(.UsedRange.Rows.Count + 1, 1)
      End With
    End If
Next

 

[John_w]

Thanks Peter. I forgot to code for the possibility of 'no Open cases' for a person. Your change fixes that.

It's not clear if cell A3, the start of the print range, is part of the table being filtered. If A3 is above the table then we determine the number of visible rows in the table itself, noting that the If statement is in a different place.

Public Sub AutoFilter_Data_Validation_Values_Print_Preview_All_Pages()

    Dim dataSheet As Worksheet, printCells As Range
    Dim table As ListObject
    Dim dataValidationCell As Range, dataValidationListCell As Range
    Dim printSheet As Worksheet, destCell As Range
    
    Application.ScreenUpdating = False
    
    With ActiveWorkbook
        Set dataSheet = .ActiveSheet
        On Error Resume Next
        Set printSheet = .Worksheets("Print")
        On Error GoTo 0
        If printSheet Is Nothing Then
            Set printSheet = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
            printSheet.Name = "Print"
        Else
            printSheet.Cells.Delete
        End If
        Set destCell = printSheet.Range("A1")
    End With
    
    With dataSheet
    
        Set table = .ListObjects("Table2")
        
        'Cell D2 contains the Data validation
        
        Set dataValidationCell = .Range("D2")
     
        'Loop through Data validation list cells
     
        For Each dataValidationListCell In Evaluate(dataValidationCell.Validation.Formula1)
        
            'Change data validation cell value and filter table
            
            dataValidationCell.Value = dataValidationListCell.Value
            table.Range.AutoFilter Field:=17, Criteria1:="Open"
            table.Range.AutoFilter Field:=4, Criteria1:=dataValidationCell.Value

            If table.ListColumns(1).Range.SpecialCells(xlCellTypeVisible).Count > 1 Then
                    
                'Copy cells to temporary print sheet
                
                Set printCells = .Range("A3:I" & .Range("A" & .Rows.Count).End(xlUp).Row)
                printCells.Copy
                destCell.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                destCell.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                destCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                'Use Format Painter to copy and paste row heights
                printCells.EntireRow.Copy
                destCell.Resize(printCells.Rows.Count).EntireRow.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Application.CutCopyMode = False
                
                'Add page break and update destination cell
                
                With printSheet
                    .HPageBreaks.Add Before:=.Rows(.UsedRange.Rows.Count + 1)
                    Set destCell = .Cells(.UsedRange.Rows.Count + 1, 1)
                End With
            
            End If
            
        Next

        'Remove autofilter
        
        table.Range.AutoFilter
        .Activate
        
    End With
        
    Application.ScreenUpdating = True
    
    printSheet.PrintPreview
    
End Sub

 

[John_w]

Well the code needs to do its own filtering, so it will lose any existing filters. I've previously written some code that saves and restores autofilter settings, so I'll try and find it and incorporate it into this macro.

I've modified the macro in post #6 to include the code which saves and restores the autofilter settings.

Public Sub AutoFilter_Data_Validation_Values_Print_Preview_All_Pages()

    Dim dataSheet As Worksheet, printCells As Range
    Dim table As ListObject
    Dim dataValidationCell As Range, dataValidationListCell As Range
    Dim printSheet As Worksheet, destCell As Range
    Dim tableAutoFilters As Variant
    
    Application.ScreenUpdating = False
    
    With ActiveWorkbook
        Set dataSheet = .ActiveSheet
        On Error Resume Next
        Set printSheet = .Worksheets("Print")
        On Error GoTo 0
        If printSheet Is Nothing Then
            Set printSheet = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
            printSheet.Name = "Print"
        Else
            printSheet.Cells.Delete
        End If
        Set destCell = printSheet.Range("A1")
    End With
    
    With dataSheet
    
        Set table = .ListObjects("Table2")
        
        'Save current filters
        
        tableAutoFilters = Get_Table_AutoFilters(table)
        
        'Cell D2 contains the Data validation
        
        Set dataValidationCell = .Range("D2")
     
        'Loop through Data validation list cells
     
        For Each dataValidationListCell In Evaluate(dataValidationCell.Validation.Formula1)
        
            'Change data validation cell value and filter table
            
            dataValidationCell.Value = dataValidationListCell.Value
            table.Range.AutoFilter 'clear current filters
            table.Range.AutoFilter Field:=17, Criteria1:="Open"
            table.Range.AutoFilter Field:=4, Criteria1:=dataValidationCell.Value

            If table.ListColumns(1).Range.SpecialCells(xlCellTypeVisible).Count > 1 Then
                    
                'Copy cells to temporary print sheet
                
                Set printCells = .Range("A3:I" & .Range("A" & .Rows.Count).End(xlUp).Row)
                printCells.Copy
                destCell.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                destCell.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                destCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                'Use Format Painter to copy and paste row heights
                printCells.EntireRow.Copy
                destCell.Resize(printCells.Rows.Count).EntireRow.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Application.CutCopyMode = False
                                
                'Add page break and update destination cell
                
                With printSheet
                    .HPageBreaks.Add Before:=.Rows(.UsedRange.Rows.Count + 1)
                    Set destCell = .Cells(.UsedRange.Rows.Count + 1, 1)
                End With
            
            End If
            
        Next

        .Activate
        
    End With
        
    Apply_AutoFilters_To_Table table, tableAutoFilters
    
    Application.ScreenUpdating = True
    
    printSheet.PrintPreview
    
End Sub


'Returns an array of the autofilter settings for the specified table.
'Based on https://stackoverflow.com/a/44937214, but for a table, instead of a worksheet

Public Function Get_Table_AutoFilters(table As ListObject) As Variant

    Dim f As Long
    Dim filt As Filter
    Dim s As String
    
    'Note - the string 's' is used only to build and output the VBA autofilter statements for information in this routine; all code involving the 's' string can be deleted
    
    If Not table.AutoFilter Is Nothing Then
        With table.AutoFilter
            With .Filters
                s = ""
                ReDim filtersarray(1 To .Count, 1 To 3) As Variant
                For f = 1 To .Count
                    Set filt = .Item(f)
                    With filt
                        If .On Then
                            s = s & "Worksheets(" & Q(table.Parent.Name) & ").ListObjects(" & Q(table.Name) & ").Range.AutoFilter Field:=" & f
                            filtersarray(f, 1) = .Criteria1
                            If IsArray(.Criteria1) Then
                                s = s & ", Criteria1:=" & Cvt_Array_String(.Criteria1)
                            Else
                                s = s & ", Criteria1:=" & Q(.Criteria1)
                            End If
                            If .Operator Then
                                filtersarray(f, 2) = .Operator
                                s = s & ", Operator:=" & Cvt_Filter_Operator(CVar(filtersarray(f, 2)))
                                On Error Resume Next
                                filtersarray(f, 3) = .Criteria2
                                On Error GoTo 0
                                If filtersarray(f, 3) <> Empty Then s = s & ", Criteria2:=" & Q(.Criteria2)
                            End If
                            s = s & vbCrLf
                        End If
                    End With
                Next
            End With
        End With
        If s <> "" Then
            'Debug.Print s
'            MsgBox table.Name & " - Worksheet " & Q(table.Parent.Name) & " Range " & table.AutoFilter.Range.Address & vbCrLf & vbCrLf & _
'                   Left(s, Len(s) - 1), Title:="AutoFilter statement(s)"
        Else
            Debug.Print "No filters applied to table: " & table.Name & " - Worksheet " & Q(table.Parent.Name) & " Range " & table.AutoFilter.Range.Address
'            MsgBox table.Name & " - Worksheet " & Q(table.Parent.Name) & " Range " & table.AutoFilter.Range.Address & vbCrLf & vbCrLf & _
'                   "No filters applied", Title:="AutoFilter statement(s)"
        End If
        Get_Table_AutoFilters = filtersarray
    End If
    
End Function


Public Sub Apply_AutoFilters_To_Table(table As ListObject, ByVal savedAutoFilters As Variant)

    Dim f As Long
    Dim Criteria1Arg As Variant, Criteria2Arg As Variant
    Dim s As String
    
    'Note - the string 's' is used only to build and output the VBA autofilter statements for information in this routine; all code involving the 's' string can be deleted
    
    s = ""
    If Not IsEmpty(savedAutoFilters) Then
        For f = 1 To UBound(savedAutoFilters)
            s = s & "Worksheets(" & Q(table.Parent.Name) & ").ListObjects(" & Q(table.Name) & ").Range.AutoFilter Field:=" & f
            If Not IsEmpty(savedAutoFilters(f, 1)) Then       'Criteria1
                If IsEmpty(savedAutoFilters(f, 2)) Then       'Operator
                    'Operator is empty, so only Criteria1 applies
                    If IsArray(savedAutoFilters(f, 1)) Then
                        s = s & ", Criteria1:=" & Cvt_Array_String(savedAutoFilters(f, 1))
                    Else
                        s = s & ", Criteria1:=" & Q(CStr(savedAutoFilters(f, 1)))
                    End If
                    table.DataBodyRange.AutoFilter Field:=f, Criteria1:=savedAutoFilters(f, 1)
                Else
                    'Operator provided
                    If IsEmpty(savedAutoFilters(f, 3)) Then   'Criteria2
                        'Criteria2 not provided, so only Criteria1 applies
                        If IsArray(savedAutoFilters(f, 1)) Then
                            s = s & ", Criteria1:=" & Cvt_Array_String(savedAutoFilters(f, 1))
                        Else
                            s = s & ", Criteria1:=" & Q(CStr(savedAutoFilters(f, 1)))
                        End If
                        s = s & ", Operator:=" & Cvt_Filter_Operator(CVar(savedAutoFilters(f, 2)))
                        table.DataBodyRange.AutoFilter Field:=f, Criteria1:=savedAutoFilters(f, 1), Operator:=savedAutoFilters(f, 2)
                    Else
                        'Criteria2 provided, so both Criteria1 and Criteria2 apply
                        If IsArray(savedAutoFilters(f, 1)) Then
                            s = s & ", Criteria1:=" & Cvt_Array_String(savedAutoFilters(f, 1))
                        Else
                            s = s & ", Criteria1:=" & Q(CStr(savedAutoFilters(f, 1)))
                        End If
                        s = s & ", Operator:=" & Cvt_Filter_Operator(CVar(savedAutoFilters(f, 2))) & ", Criteria2:=" & Q(CStr(savedAutoFilters(f, 3)))
                        table.DataBodyRange.AutoFilter Field:=f, Criteria1:=savedAutoFilters(f, 1), Operator:=savedAutoFilters(f, 2), Criteria2:=savedAutoFilters(f, 3)
                    End If
                End If
            Else
                table.DataBodyRange.AutoFilter Field:=f
            End If
            s = s & vbCrLf
        Next
    Else
        'No filters
        table.DataBodyRange.AutoFilter
    End If
    'Debug.Print s
    
End Sub


Private Function Cvt_Array_String(arr As Variant) As String

    Dim i As Long
    
    Cvt_Array_String = "Array("
    For i = LBound(arr) To UBound(arr)
        Cvt_Array_String = Cvt_Array_String & Q(Replace(arr(i), "=", "")) & ", "
    Next
    Cvt_Array_String = Left(Cvt_Array_String, Len(Cvt_Array_String) - 2) & ")"
    
End Function


Private Function Cvt_Filter_Operator(op As XlAutoFilterOperator) As String
    
    Select Case op
        Case XlAutoFilterOperator.xlAnd: Cvt_Filter_Operator = "xlAnd"
        Case XlAutoFilterOperator.xlBottom10Items: Cvt_Filter_Operator = "xlBottom10Items"
        Case XlAutoFilterOperator.xlBottom10Percent: Cvt_Filter_Operator = "xlBottom10Percent"
        Case XlAutoFilterOperator.xlFilterAutomaticFontColor: Cvt_Filter_Operator = "xlFilterAutomaticFontColor"
        Case XlAutoFilterOperator.xlFilterCellColor: Cvt_Filter_Operator = "xlFilterCellColor"
        Case XlAutoFilterOperator.xlFilterDynamic: Cvt_Filter_Operator = "xlFilterDynamic"
        Case XlAutoFilterOperator.xlFilterFontColor: Cvt_Filter_Operator = "xlFilterFontColor"
        Case XlAutoFilterOperator.xlFilterIcon: Cvt_Filter_Operator = "xlFilterIcon"
        Case XlAutoFilterOperator.xlFilterNoFill: Cvt_Filter_Operator = "xlFilterNoFill"
        Case XlAutoFilterOperator.xlFilterNoIcon: Cvt_Filter_Operator = "xlFilterNoIcon"
        Case XlAutoFilterOperator.xlFilterValues: Cvt_Filter_Operator = "xlFilterValues"
        Case XlAutoFilterOperator.xlOr: Cvt_Filter_Operator = "xlOr"
        Case XlAutoFilterOperator.xlTop10Items: Cvt_Filter_Operator = "xlTop10Items"
        Case XlAutoFilterOperator.xlTop10Percent: Cvt_Filter_Operator = "xlTop10Percent"
        Case Else: Cvt_Filter_Operator = "**UNKNOWN**"
    End Select
    
End Function

Private Function Q(ByVal text As String) As String
    Q = Chr(34) & text & Chr(34)
End Function