VBA Filter

SavGDK · #1 10-13-2016, 05:20 AM

I am hoping somebody can help me with a VBA issue. I have multiple worksheets with a filtering equation set up on each sheet. On the main page of the workbook I want to set up a filter that will automatically filter all the pages. I have attached a screenshot of my VBA Code. I eventually want to add all the pages to this code but thought it would be easier to start with one page.

Thank you,

Dan

charlesdh · #2 10-13-2016, 12:45 PM

Hi,

You can look at this code too see if it will help you.
It loops thru specific sheet and applies a filter then copy and paste to a worksheet.

Code:

Sub test41()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim Sws As Worksheet
Dim Rng As Range
Dim Myval As Long
Set Sws = Sheets("Summary")
'''' Unhide Summary columns "K thru Q'''''
Sws.Columns("K:Q").Hidden = True
''''
For Each ws In ActiveWorkbook.Worksheets
    ws.Activate
    If InStr("Lookup", ws.Name) = 0 And InStr("Summary", ws.Name) = 0 Then
    Select Case ws.Name
         Case "Crawler"
            Range("A1:d1").Select
            ws.Columns("K:R").Hidden = False
            Selection.AutoFilter
            With Selection
                .AutoFilter Field:=1, Criteria1:="<>F" '' this set the filtered data for the value"
            End With
            Set Rng = ActiveSheet.AutoFilter.Range
            lrow = ActiveSheet.Range("A65536").End(xlUp).Row
            '' make sure you have more than 1 row to copy ''
            Myval = Range("a2:a" & lrow).SpecialCells(xlCellTypeVisible).Count
            If Myval <> "1" Then
               Rlrow = Sheets("Summary").Range("A65536").End(xlUp).Row + 1
                    Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1, 22).Copy
                        Sheets("Summary").Cells(Rlrow, 1).PasteSpecial xlAll
                    Application.CutCopyMode = xlCopy
            End If
        Case "Various"
            Range("A1:d1").Select
            ws.Columns("K:R").Hidden = False
            Selection.AutoFilter
            With Selection
                .AutoFilter Field:=1, Criteria1:="<>F" '' this set the filtered data for the value"
            End With
            Set Rng = ActiveSheet.AutoFilter.Range
            lrow = ActiveSheet.Range("A65536").End(xlUp).Row
            '' make sure you have more than 1 row to copy ''
            Myval = Range("a2:a" & lrow).SpecialCells(xlCellTypeVisible).Count
            If Myval <> "1" Then
               Rlrow = Sheets("Summary").Range("A65536").End(xlUp).Row + 1
                    Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1, 22).Copy
                        Sheets("Summary").Cells(Rlrow, 1).PasteSpecial xlAll
                    Application.CutCopyMode = xlCopy
            End If
        Case "MandM"
            Range("A1:d1").Select
            ws.Columns("K:R").Hidden = False
            Selection.AutoFilter
            With Selection
                .AutoFilter Field:=1, Criteria1:="<>F" '' this set the filtered data for the value"
            End With
            Set Rng = ActiveSheet.AutoFilter.Range
            lrow = ActiveSheet.Range("A65536").End(xlUp).Row
            '' make sure you have more than 1 row to copy ''
            Myval = Range("a2:a" & lrow).SpecialCells(xlCellTypeVisible).Count
            If Myval <> "1" Then
               Rlrow = Sheets("Summary").Range("A65536").End(xlUp).Row + 1
                    Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1, 22).Copy
                        Sheets("Summary").Cells(Rlrow, 1).PasteSpecial xlAll
                    Application.CutCopyMode = xlCopy
            End If
        Case "Fragrance"
            Range("A1:d1").Select
            ws.Columns("K:R").Hidden = False
            Selection.AutoFilter
            With Selection
                .AutoFilter Field:=1, Criteria1:="<>F" '' this set the filtered data for the value"
            End With
            Set Rng = ActiveSheet.AutoFilter.Range
            lrow = ActiveSheet.Range("A65536").End(xlUp).Row
            '' make sure you have more than 1 row to copy ''
            Myval = Range("a2:a" & lrow).SpecialCells(xlCellTypeVisible).Count
            If Myval <> "1" Then
               Rlrow = Sheets("Summary").Range("A65536").End(xlUp).Row + 1
                    Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1, 22).Copy
                        Sheets("Summary").Cells(Rlrow, 1).PasteSpecial xlAll
                    Application.CutCopyMode = xlCopy
            End If
        Case "5£"
            Range("A1:d1").Select
            ws.Columns("K:R").Hidden = False
            Selection.AutoFilter
            With Selection
                .AutoFilter Field:=1, Criteria1:="<>F" '' this set the filtered data for the value"
            End With
            Set Rng = ActiveSheet.AutoFilter.Range
            lrow = ActiveSheet.Range("A65536").End(xlUp).Row
            '' make sure you have more than 1 row to copy ''
            Myval = Range("a2:a" & lrow).SpecialCells(xlCellTypeVisible).Count
            If Myval <> "1" Then
               Rlrow = Sheets("Summary").Range("A65536").End(xlUp).Row + 1
                    Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1, 22).Copy
                        Sheets("Summary").Cells(Rlrow, 1).PasteSpecial xlAll
                    Application.CutCopyMode = xlCopy
            End If
        Case Else
        '''' Activate Summary and Hide columns '''

            Sws.Activate
            Sws.Range("A1").Select
            Sws.Columns("K:Q").Hidden = True
            Exit Sub
    End Select
    Selection.AutoFilter
    End If
    ws.Columns("K:R").Hidden = True
Next ws
End Sub

SavGDK · #3 10-14-2016, 11:37 AM

Charles,

Thanks for the help. I will give it a try. I was hoping it would be a little simpler than creating a copy. My workbook is already really big. If I attach the workbook would that help?

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Filter Mail Merge based on a list of filter criteria	AusSteelMan	Mail Merge	2	05-09-2016 03:35 PM
how to filter using hyperlick?	nicholes	Excel Programming	20	04-16-2015 03:54 AM
Help Date filter	Herve86	Outlook	0	05-28-2012 04:43 AM
Apply filter with VBA	bobsawyer7	Outlook	0	03-12-2012 04:02 AM
filter	kwlickt	Excel	1	03-28-2011 11:15 AM