I'm completely new to writing macros and used the record function to start the script for my macro and then used Google to basically adjust my code as I needed to. Now I've run into a more complicated filtering issue that I need help on. Basically, the macro is to filter out 0s from columns G, H and J, and copy the results of column A for each filter into a new sheet. The data I work with is different every time and sometimes, column H only has 0s in it. When this happens, the macro will copy all the results under column A and paste it into the new sheet. But I don't want the results of 0s. How do I tell my macro that if the filtering options are only 0, don't copy/paste and move onto the next step? This is my current macro code:

Sub ProactiveHTAT()
'
' Test1 Macro
' Proactive HTAT
'

'
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$T$1000").AutoFilter Field:=19, Criteria1:="Pass"
    ActiveSheet.Range("$A$1:$T$1000").AutoFilter Field:=7, Criteria1:="<>0"
    Range(("A2"), Range("A2").End(xlDown)).Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    ActiveSheet.Range("$A$1:$T$500").AutoFilter Field:=7
    ActiveSheet.Range("$A$1:$T$500").AutoFilter Field:=8, Criteria1:="<>0"
    Selection.Copy
    Sheets("Sheet2").Select
    ActiveSheet.Range("A1").End(xlDown).Offset(1, 0).Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    ActiveSheet.Range("$A$1:$T$500").AutoFilter Field:=8
    ActiveSheet.Range("$A$1:$T$500").AutoFilter Field:=10, Criteria1:="<>0"
    Selection.Copy
    Sheets("Sheet2").Select
    ActiveSheet.Range("A1").End(xlDown).Offset(1, 0).Select
    ActiveSheet.Paste
    ActiveSheet.Range(("A1"), Range("A1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

I'm completely new to writing macros and used the record function to start the script for my macro and then used Google to basically adjust my code as I needed to. Now I've run into a more complicated filtering issue that I need help on. Basically, the macro is to filter out 0s from columns G, H and J, and copy the results of column A for each filter into a new sheet. The data I work with is different every time and sometimes, column H only has 0s in it. When this happens, the macro will copy all the results under column A and paste it into the new sheet. But I don't want the results of 0s. How do I tell my macro that if the filtering options are only 0, don't copy/paste and move onto the next step? This is my current macro code:

Sub ProactiveHTAT()
'
' Test1 Macro
' Proactive HTAT
'

'
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$T$1000").AutoFilter Field:=19, Criteria1:="Pass"
    ActiveSheet.Range("$A$1:$T$1000").AutoFilter Field:=7, Criteria1:="<>0"
    Range(("A2"), Range("A2").End(xlDown)).Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    ActiveSheet.Range("$A$1:$T$500").AutoFilter Field:=7
    ActiveSheet.Range("$A$1:$T$500").AutoFilter Field:=8, Criteria1:="<>0"
    Selection.Copy
    Sheets("Sheet2").Select
    ActiveSheet.Range("A1").End(xlDown).Offset(1, 0).Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    ActiveSheet.Range("$A$1:$T$500").AutoFilter Field:=8
    ActiveSheet.Range("$A$1:$T$500").AutoFilter Field:=10, Criteria1:="<>0"
    Selection.Copy
    Sheets("Sheet2").Select
    ActiveSheet.Range("A1").End(xlDown).Offset(1, 0).Select
    ActiveSheet.Paste
    ActiveSheet.Range(("A1"), Range("A1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

• excel
• vba

• 3 Please do not post screenshots of your code. No one can copy/paste it when it's a screenshot. – braX Commented Mar 14 at 19:24
• I'm sorry! I tried to copy/paste the code into the body, but it wasn't letting me click the post button. I was getting an error message telling me that the format was wrong. I tried to Ctrl+K as instructed in the error message, but the error wasn't going away. I wasn't sure how else to post it. – Hazel Commented Mar 14 at 19:27
• Try 3 backticks, newline, the code, newline, then 3 backticks again. – braX Commented Mar 14 at 19:29

2 Answers 2

It looks like you want to turn on one Filter (ColS="Pass")
Toggle 3 different filters (Cols G, H, and J)
Copy the results of each to a single column in a new worksheet
Remove duplicates in ColA of your new worksheet
Here's the VBA that I've come up with. If one of your columns (G, H, or J) is all 0s, then ColA on your new worksheet might have a blank row....that's for the column with all 0s. If needed, that can be removed.

Sub Filtering_WithPass()
'''store filter results
Dim arr
arr = ActiveSheet.Evaluate("=UNIQUE(VSTACK(FILTER(A2:A1000,(S2:S1000=""Pass"")*(G2:G1000<>0),""""),FILTER(A2:A1000,(S2:S1000=""Pass"")*(H2:H1000<>0),""""),FILTER(A2:A1000,(S2:S1000=""Pass"")*(J2:J1000<>0),"""")))")
'''copy the results to a different sheet
Dim ws As Worksheet
Set ws = Sheets.Add(after:=ActiveSheet)
ws.Range("A1").Resize(UBound(arr, 1)).Value = arr
End Sub

Option 1

• Using ActiveSheet is not reliable, especially when a new sheet is created within the script.
• The table range reference can be determined dynamically.
• If the filtered table is empty (no rows in the data body range), the script incorrectly copies all cells in Column A to the output sheet.

Option Explicit

Sub ProactiveHTAT()
    Dim srcSht As Worksheet: Set srcSht = ActiveSheet
    With srcSht
        ' get range of the data table
        Dim rTab As Range: Set rTab = .Range("A1").CurrentRegion
        ' get the 1st column of data body in table (w/o header row)
        Dim rColA As Range: Set rColA = rTab.Resize(rTab.Rows.Count - 1).Offset(1).Columns(1)
        ' show all data in table
        If .AutoFilterMode Then
            If .AutoFilter.FilterMode Then
                .ShowAllData
            End If
        End If
    End With
    ' first filter
    rTab.AutoFilter Field:=19, Criteria1:="Pass"
    Dim desSht As Worksheet
    ' create a new sheet
    Set desSht = Sheets.Add(After:=srcSht)
    Dim rCell As Range: Set rCell = desSht.Range("A1")
    Dim iCol, lastRow As Long
    ' loop through the 2nd filter column
    For Each iCol In Array(7, 8, 10)
        ' apply the 2nd filter
        rTab.AutoFilter Field:=iCol, Criteria1:="<>0"
        ' get the last row#
        lastRow = srcSht.Cells(srcSht.Rows.Count, 1).End(xlUp).Row
        If lastRow > 1 Then ' filtered table is NOT blank
            rColA.Copy rCell ' copy to dest. sheet
            ' get the next blank cell
            Set rCell = desSht.Cells(desSht.Rows.Count, 1).End(xlUp).Offset(1)
        End If
        ' remove the 2nd filter
        rTab.AutoFilter Field:=iCol
    Next
    ' remove duplicated values on dest. sheet
    desSht.Range("A1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

Option 2: The second option is more efficient for processing data in an array.

Sub ProactiveHTAT2()
    Dim srcSht As Worksheet: Set srcSht = ActiveSheet
    ' load table into an array
    Dim arr: arr = srcSht.Range("A1").CurrentRegion.Value
    Dim brr: ReDim brr(1 To UBound(arr), 0)
    Dim i As Long, iR As Long
    For i = LBound(arr) + 1 To UBound(arr)
        ' check the 1st filter
        If arr(i, 19) = "Pass" Then
            ' check the 2nd filter
            If arr(i, 7) & arr(i, 8) & arr(i, 10) <> "000" Then
                iR = iR + 1
                brr(iR, 0) = arr(i, 1)
            End If
        End If
    Next
    If iR > 0 Then
        Dim desSht As Worksheet
        Set desSht = Sheets.Add(After:=srcSht)
        desSht.Range("A1").Resize(iR).Value = brr
    End If
End Sub