Filter a Range with values which I don't want - excel

ThisWorkbook.Sheets(1).Range("A1:AR1").AutoFilter Field:=27, _
Criteria1:=Array("<>DRCA", "<>DREX", "<>DRFU", "<>DRIN", _
"<>DRIR", "<>DRND", "<>DRPN", "<>DRPR", "<>DRRE", "<>DRUN", _
"<>REXC", "<>EXCD", "<>RFUR", "<>RINV", "<>RIRC", "<>RNDR", _
"<>RPNA", "<>RPRO", "<>RRET", "<>RUND", "<>RUNF", "<>EXC", "<>C"), _
Operator:=xlFilterValues
This is not returning correct filter data that I want. What I want is that if array doesn't find any <> value then skip it and check next.
How do I go about it?

Excel doesn't allow you to use the array like you want it in the Autofilter. But is there an alternative? Yes!
Logic If I ask you choose numbers between 0 and 10 including 0 and 10 but you cannot choose 0, 5, 8 and 10. So instead of filtering the numbers out and saying I don't want 0, 5, 8 and 10, you can say I want 1,2,3,4,6,7,9.
Similarly in your case we will not filter on the values we DON'T want. We will filter on values we WANT.
So HOW do we find that list and store it in an array?
Find the last row in the relevant column.
Store all records from that column in a unique collection
Check which items in that collection are not in the "exclude" list and create an array.
Filter the range on the values(array) you want! This way we will not have to filter on the values which we don't want.
Code (Tested in Excel 2013 with 50k records)
I have commented the code but if you still have any questions then feel free to ask :)
Dim OmitArray As Variant
Const deLim As String = "|"
Sub Sample()
Dim Ws As Worksheet
Dim lRow As Long, i As Long, n As Long, lCol As Long
Dim Col As New Collection, itm
Dim includeArray As Variant
Dim rng As Range
Dim tmpString As String
'~~> This array has all the values that you want to ignore
OmitArray = Array("DRCA", "DREX", "DRFU", "DRIN", "DRIR", "DRND", _
"DRPN", "DRPR", "DRRE", "DRUN", "REXC", "EXCD", "RFUR", _
"RINV", "RIRC", "RNDR", "RPNA", "RPRO", "RRET", "RUND", _
"RUNF", "EXC", "C")
'~~> This is the column where you want to filter out
lCol = 27
'~~> Change this to the relevant worksheet
Set Ws = ThisWorkbook.Sheets("Sheet1")
With Ws
'~~> Find lastrow
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> This is the range where the filter will be applied
Set rng = .Range("A1:AR" & lRow)
'~~> All all the values from col 27 to a unique collection
For i = 2 To lRow
On Error Resume Next
Col.Add .Cells(i, lCol).Value, CStr(.Cells(i, 27).Value)
On Error GoTo 0
Next i
'~~> Now loop though the collection and store the values in a string
'~~> delimited with a delimiter which arenot present in the "OmitArray"
For Each itm In Col
If Not IsInArray(itm, OmitArray) Then
If tmpString = "" Then
tmpString = itm
Else
tmpString = tmpString & deLim & itm
End If
End If
Next itm
If tmpString <> "" Then
'~~> Split the values based on the delimiter to create array
includeArray = Split(tmpString, deLim)
'~~> Remove any filters
.AutoFilterMode = False
'~~> Filter on the rest of the values
With rng
.AutoFilter Field:=lCol, Criteria1:=includeArray, Operator:=xlFilterValues
End With
End If
End With
End Sub
'~~> Function to check if there is an item in the array
Function IsInArray(stringToBeFound As Variant, arr As Variant) As Boolean
Dim bDimen As Byte, i As Long
On Error Resume Next
If IsError(UBound(arr, 2)) Then bDimen = 1 Else bDimen = 2
On Error GoTo 0
Select Case bDimen
Case 1
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, arr, 0)
On Error GoTo 0
Case 2
For i = 1 To UBound(arr, 2)
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, Application.Index(arr, , i), 0)
On Error GoTo 0
If IsInArray = True Then Exit For
Next
End Select
End Function

You cannot use the AutoFilter from VBA to explicitly exclude more than two values for a given field. Instead you need to specify the values you want included.
But you do not need to use the AutoFilter to hide the rows containing specific values.
Here is a short routine that will work in your case. You can manage which rows to hide by editing the first line:
Public Sub Demo()
Const HIDE = ".DRCA.DREX.DRFU.DRIN.DRIR.DRND.DRPN.DRPR.DRRE.DRUN.REXC.EXCD.RFUR.RINV.RIRC.RNDR.RPNA.RPRO.RRET.RUND.RUNF.EXC.C."
Dim c As Range
With ThisWorkbook.Sheets(1)
For Each c In .Range("AR1:AR" & .Range("AR" & .Rows.Count).End(xlUp).Row)
If InStr(HIDE, "." & c & ".") Then
c.EntireRow.Hidden = True
End If
Next
End With
End Sub

Related

filterout multiple value from table using vba [duplicate]

I have 8 variables in column A, 1,2,3,4,5 and A, B, C.
My aim is to filter out A, B, C and display only 1-5.
I can do this using the following code:
My_Range.AutoFilter Field:=1, Criteria1:=Array("1", "2", "3","4","5"), _
Operator:=xlFilterValues
But what the code does is it filters variables 1 to 5 and displays them.
I want to do the opposite, but yielding the same result, by filtering out A, B, C and showing variables 1 to 5
I tried this code:
My_Range.AutoFilter Field:=1, Criteria1:=Array("<>A", "<>B", "<>C"), _
Operator:=xlFilterValues
But it did not work.
Why cant I use this code ?
It gives this error:
Run time error 1004 autofilter method of range class failed
How can I perform this?
I think (from experimenting - MSDN is unhelpful here) that there is no direct way of doing this. Setting Criteria1 to an Array is equivalent to using the tick boxes in the dropdown - as you say it will only filter a list based on items that match one of those in the array.
Interestingly, if you have the literal values "<>A" and "<>B" in the list and filter on these the macro recorder comes up with
Range.AutoFilter Field:=1, Criteria1:="=<>A", Operator:=xlOr, Criteria2:="=<>B"
which works. But if you then have the literal value "<>C" as well and you filter for all three (using tick boxes) while recording a macro, the macro recorder replicates precisely your code which then fails with an error. I guess I'd call that a bug - there are filters you can do using the UI which you can't do with VBA.
Anyway, back to your problem. It is possible to filter values not equal to some criteria, but only up to two values which doesn't work for you:
Range("$A$1:$A$9").AutoFilter Field:=1, Criteria1:="<>A", Criteria2:="<>B", Operator:=xlAnd
There are a couple of workarounds possible depending on the exact problem:
Use a "helper column" with a formula in column B and then filter on that - e.g. =ISNUMBER(A2) or =NOT(A2="A", A2="B", A2="C") then filter on TRUE
If you can't add a column, use autofilter with Criteria1:=">-65535" (or a suitable number lower than any you expect) which will filter out non-numeric values - assuming this is what you want
Write a VBA sub to hide rows (not exactly the same as an autofilter but it may suffice depending on your needs).
For example:
Public Sub hideABCRows(rangeToFilter As Range)
Dim oCurrentCell As Range
On Error GoTo errHandler
Application.ScreenUpdating = False
For Each oCurrentCell In rangeToFilter.Cells
If oCurrentCell.Value = "A" Or oCurrentCell.Value = "B" Or oCurrentCell.Value = "C" Then
oCurrentCell.EntireRow.Hidden = True
End If
Next oCurrentCell
Application.ScreenUpdating = True
Exit Sub
errHandler:
Application.ScreenUpdating = True
End Sub
I don't have found any solution on Internet, so I have implemented one.
The Autofilter code with criteria is then
iColNumber = 1
Dim aFilterValueArray() As Variant
Call ConstructFilterValueArray(aFilterValueArray, iColNumber, Array("A", "B", "C"))
ActiveSheet.range(sRange).AutoFilter Field:=iColNumber _
, Criteria1:=aFilterValueArray _
, Operator:=xlFilterValues
In fact, the ConstructFilterValueArray() method (not function) get all distinct values that it found in a specific column and remove all values present in last argument.
The VBA code of this method is
'************************************************************
'* ConstructFilterValueArray()
'************************************************************
Sub ConstructFilterValueArray(a() As Variant, iCol As Integer, aRemoveArray As Variant)
Dim aValue As New Collection
Call GetDistinctColumnValue(aValue, iCol)
Call RemoveValueList(aValue, aRemoveArray)
Call CollectionToArray(a, aValue)
End Sub
'************************************************************
'* GetDistinctColumnValue()
'************************************************************
Sub GetDistinctColumnValue(ByRef aValue As Collection, iCol As Integer)
Dim sValue As String
iEmptyValueCount = 0
iLastRow = ActiveSheet.UsedRange.Rows.Count
Dim oSheet: Set oSheet = Sheets("X")
Sheets("Data")
.range(Cells(1, iCol), Cells(iLastRow, iCol)) _
.AdvancedFilter Action:=xlFilterCopy _
, CopyToRange:=oSheet.range("A1") _
, Unique:=True
iRow = 2
Do While True
sValue = Trim(oSheet.Cells(iRow, 1))
If sValue = "" Then
If iEmptyValueCount > 0 Then
Exit Do
End If
iEmptyValueCount = iEmptyValueCount + 1
End If
aValue.Add sValue
iRow = iRow + 1
Loop
End Sub
'************************************************************
'* RemoveValueList()
'************************************************************
Sub RemoveValueList(ByRef aValue As Collection, aRemoveArray As Variant)
For i = LBound(aRemoveArray) To UBound(aRemoveArray)
sValue = aRemoveArray(i)
iMax = aValue.Count
For j = iMax To 0 Step -1
If aValue(j) = sValue Then
aValue.Remove (j)
Exit For
End If
Next j
Next i
End Sub
'************************************************************
'* CollectionToArray()
'************************************************************
Sub CollectionToArray(a() As Variant, c As Collection)
iSize = c.Count - 1
ReDim a(iSize)
For i = 0 To iSize
a(i) = c.Item(i + 1)
Next
End Sub
This code can certainly be improved in returning an Array of String but working with Array in VBA is not easy.
CAUTION: this code work only if you define a sheet named X because CopyToRange parameter used in AdvancedFilter() need an Excel Range !
It's a shame that Microfsoft doesn't have implemented this solution in adding simply a new enum as xlNotFilterValues ! ... or xlRegexMatch !
Alternative using VBA's Filter function
As an innovative alternative to #schlebe 's recent answer, I tried to use the Filter function integrated in VBA, which allows to filter out a given search string setting the third argument to False. All "negative" search strings (e.g. A, B, C) are defined in an array. I read the criteria in column A to a datafield array and basicly execute a subsequent filtering (A - C) to filter these items out.
Code
Sub FilterOut()
Dim ws As Worksheet
Dim rng As Range, i As Integer, n As Long, v As Variant
' 1) define strings to be filtered out in array
Dim a() ' declare as array
a = Array("A", "B", "C") ' << filter out values
' 2) define your sheetname and range (e.g. criteria in column A)
Set ws = ThisWorkbook.Worksheets("FilterOut")
n = ws.Range("A" & ws.Rows.Count).End(xlUp).row
Set rng = ws.Range("A2:A" & n)
' 3) hide complete range rows temporarily
rng.EntireRow.Hidden = True
' 4) set range to a variant 2-dim datafield array
v = rng
' 5) code array items by appending row numbers
For i = 1 To UBound(v): v(i, 1) = v(i, 1) & "#" & i + 1: Next i
' 6) transform to 1-dim array and FILTER OUT the first search string, e.g. "A"
v = Filter(Application.Transpose(Application.Index(v, 0, 1)), a(0), False, False)
' 7) filter out each subsequent search string, i.e. "B" and "C"
For i = 1 To UBound(a): v = Filter(v, a(i), False, False): Next i
' 8) get coded row numbers via split function and unhide valid rows
For i = LBound(v) To UBound(v)
ws.Range("A" & Split(v(i) & "#", "#")(1)).EntireRow.Hidden = False
Next i
End Sub
An option using AutoFilter
Option Explicit
Public Sub FilterOutMultiple()
Dim ws As Worksheet, filterOut As Variant, toHide As Range
Set ws = ActiveSheet
If Application.WorksheetFunction.CountA(ws.Cells) = 0 Then Exit Sub 'Empty sheet
filterOut = Split("A B C D E F G")
Application.ScreenUpdating = False
With ws.UsedRange.Columns("A")
If ws.FilterMode Then .AutoFilter
.AutoFilter Field:=1, Criteria1:=filterOut, Operator:=xlFilterValues
With .SpecialCells(xlCellTypeVisible)
If .CountLarge > 1 Then Set toHide = .Cells 'Remember unwanted (A, B, and C)
End With
.AutoFilter
If Not toHide Is Nothing Then
toHide.Rows.Hidden = True 'Hide unwanted (A, B, and C)
.Cells(1).Rows.Hidden = False 'Unhide header
End If
End With
Application.ScreenUpdating = True
End Sub
Here an option using a list written on some range, populating an array that will be fiiltered. The information will be erased then the columns sorted.
Sub Filter_Out_Values()
'Automation to remove some codes from the list
Dim ws, ws1 As Worksheet
Dim myArray() As Variant
Dim x, lastrow As Long
Dim cell As Range
Set ws = Worksheets("List")
Set ws1 = Worksheets(8)
lastrow = ws.Cells(Application.Rows.Count, 1).End(xlUp).Row
'Go through the list of codes to exclude
For Each cell In ws.Range("A2:A" & lastrow)
If cell.Offset(0, 2).Value = "X" Then 'If the Code is associated with "X"
ReDim Preserve myArray(x) 'Initiate array
myArray(x) = CStr(cell.Value) 'Populate the array with the code
x = x + 1 'Increase array capacity
ReDim Preserve myArray(x) 'Redim array
End If
Next cell
lastrow = ws1.Cells(Application.Rows.Count, 1).End(xlUp).Row
ws1.Range("C2:C" & lastrow).AutoFilter field:=3, Criteria1:=myArray, Operator:=xlFilterValues
ws1.Range("A2:Z" & lastrow).SpecialCells(xlCellTypeVisible).ClearContents
ws1.Range("A2:Z" & lastrow).AutoFilter field:=3
'Sort columns
lastrow = ws1.Cells(Application.Rows.Count, 1).End(xlUp).Row
'Sort with 2 criteria
With ws1.Range("A1:Z" & lastrow)
.Resize(lastrow).Sort _
key1:=ws1.Columns("B"), order1:=xlAscending, DataOption1:=xlSortNormal, _
key2:=ws1.Columns("D"), order1:=xlAscending, DataOption1:=xlSortNormal, _
Header:=xlYes, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
End With
End Sub
This works for me:
This is a criteria over two fields/columns (9 and 10), this filters rows with values >0 on column 9 and rows with values 4, 7, and 8 on column 10. lastrow is the number of rows on the data section.
ActiveSheet.Range("$A$1:$O$" & lastrow).AutoFilter Field:=9, Criteria1:=">0", Operator:=xlAnd
ActiveSheet.Range("$A$1:$O$" & lastrow).AutoFilter Field:=10, Criteria1:=Arr("4","7","8"), Operator:=xlFilterValues
Okay, I solved it.
I've smashed my head about this problem several times over the years, but I've solved it.
All we need to do is look at all the values that are actually IN the filter range, and if they're not on the list of values we want to filter out, we add them to the "Filter For this item" list.
To note about this code:
I wrote this to act on multiple sheets, and I'm not going to change that as I'm at work and don't have time. I'm sure you can figure it out.
I don't think you need to work in Option base 1... But I am, so if you run into issues... might be that.
Despite how many hundreds of thousands of times it's checking and rechecking the same arrays, it's remarkably fast.
I'm sure there is a way to redim KeepArray, but I didn't have time to consider it.
Option Explicit
Option Base 1
Sub FilterTable()
Dim WS As Worksheet
Dim L As Long
Dim I As Long
Dim N As Long
Dim tbl As ListObject
Dim tblName As String
Dim filterArray
Dim SrcArray
Dim KeepArray(1 To 5000) ' you might be able to figure out a way to redim this easiely later on.. for now I'm just oversizing it.
N = 0
filterArray = Array("FilterMeOut007", _
"FilterMeOut006", _
"FilterMeOut005", _
"FilterMeOut004", _
"FilterMeOut003", _
"FilterMeOut002", _
"FilterMeOut001")
For Each WS In ThisWorkbook.Worksheets
Debug.Print WS.Name
If Left(WS.Name, 4) = "AR -" Then
With WS
tblName = Replace(WS.Name, " ", "_")
Set tbl = WS.ListObjects(tblName)
SrcArray = tbl.ListColumns(1).DataBodyRange
For I = 1 To UBound(SrcArray, 1)
If Not ExistsInArray(KeepArray, SrcArray(I, 1)) _
And Not ExistsInArray(filterArray, SrcArray(I, 1)) Then
N = N + 1
KeepArray(N) = SrcArray(I, 1)
End If
Next I
tbl.DataBodyRange.AutoFilter Field:=1, Criteria1:=KeepArray, Operator:=xlFilterValues
End With
End If
Next WS
End Sub
Function ExistsInArray(arr, Val) As Boolean
Dim I As Long
ExistsInArray = False
For I = LBound(arr) To UBound(arr)
If arr(I) = Val Then
ExistsInArray = True
Exit Function
End If
Next I
End Function
Please let me know if you run into any errors with this as I'd like to stress test and debug it as much as possible in the future to make it as portable as possible. I picture using it a lot.
Please check this one for filtering out values in a range; It works.
Selection.AutoFilter field:=33, Criteria1:="<>Array(IN1R,IN2R,INDA)", Operator:=xlFilterValues
Actually, the above code did not work. Hence I give a loop to hide the entire row whenever the active cell has the value that I am searching for.
For each cell in selection
If cell.value = “IN1R” or cell.value = “INR2” or cell.value = “INDA” then
Else
Activecell.Entirerow.Hidden = True
End if
Next

AutoFilter rows when multiple columns are 0 in VBA [duplicate]

I have 8 variables in column A, 1,2,3,4,5 and A, B, C.
My aim is to filter out A, B, C and display only 1-5.
I can do this using the following code:
My_Range.AutoFilter Field:=1, Criteria1:=Array("1", "2", "3","4","5"), _
Operator:=xlFilterValues
But what the code does is it filters variables 1 to 5 and displays them.
I want to do the opposite, but yielding the same result, by filtering out A, B, C and showing variables 1 to 5
I tried this code:
My_Range.AutoFilter Field:=1, Criteria1:=Array("<>A", "<>B", "<>C"), _
Operator:=xlFilterValues
But it did not work.
Why cant I use this code ?
It gives this error:
Run time error 1004 autofilter method of range class failed
How can I perform this?
I think (from experimenting - MSDN is unhelpful here) that there is no direct way of doing this. Setting Criteria1 to an Array is equivalent to using the tick boxes in the dropdown - as you say it will only filter a list based on items that match one of those in the array.
Interestingly, if you have the literal values "<>A" and "<>B" in the list and filter on these the macro recorder comes up with
Range.AutoFilter Field:=1, Criteria1:="=<>A", Operator:=xlOr, Criteria2:="=<>B"
which works. But if you then have the literal value "<>C" as well and you filter for all three (using tick boxes) while recording a macro, the macro recorder replicates precisely your code which then fails with an error. I guess I'd call that a bug - there are filters you can do using the UI which you can't do with VBA.
Anyway, back to your problem. It is possible to filter values not equal to some criteria, but only up to two values which doesn't work for you:
Range("$A$1:$A$9").AutoFilter Field:=1, Criteria1:="<>A", Criteria2:="<>B", Operator:=xlAnd
There are a couple of workarounds possible depending on the exact problem:
Use a "helper column" with a formula in column B and then filter on that - e.g. =ISNUMBER(A2) or =NOT(A2="A", A2="B", A2="C") then filter on TRUE
If you can't add a column, use autofilter with Criteria1:=">-65535" (or a suitable number lower than any you expect) which will filter out non-numeric values - assuming this is what you want
Write a VBA sub to hide rows (not exactly the same as an autofilter but it may suffice depending on your needs).
For example:
Public Sub hideABCRows(rangeToFilter As Range)
Dim oCurrentCell As Range
On Error GoTo errHandler
Application.ScreenUpdating = False
For Each oCurrentCell In rangeToFilter.Cells
If oCurrentCell.Value = "A" Or oCurrentCell.Value = "B" Or oCurrentCell.Value = "C" Then
oCurrentCell.EntireRow.Hidden = True
End If
Next oCurrentCell
Application.ScreenUpdating = True
Exit Sub
errHandler:
Application.ScreenUpdating = True
End Sub
I don't have found any solution on Internet, so I have implemented one.
The Autofilter code with criteria is then
iColNumber = 1
Dim aFilterValueArray() As Variant
Call ConstructFilterValueArray(aFilterValueArray, iColNumber, Array("A", "B", "C"))
ActiveSheet.range(sRange).AutoFilter Field:=iColNumber _
, Criteria1:=aFilterValueArray _
, Operator:=xlFilterValues
In fact, the ConstructFilterValueArray() method (not function) get all distinct values that it found in a specific column and remove all values present in last argument.
The VBA code of this method is
'************************************************************
'* ConstructFilterValueArray()
'************************************************************
Sub ConstructFilterValueArray(a() As Variant, iCol As Integer, aRemoveArray As Variant)
Dim aValue As New Collection
Call GetDistinctColumnValue(aValue, iCol)
Call RemoveValueList(aValue, aRemoveArray)
Call CollectionToArray(a, aValue)
End Sub
'************************************************************
'* GetDistinctColumnValue()
'************************************************************
Sub GetDistinctColumnValue(ByRef aValue As Collection, iCol As Integer)
Dim sValue As String
iEmptyValueCount = 0
iLastRow = ActiveSheet.UsedRange.Rows.Count
Dim oSheet: Set oSheet = Sheets("X")
Sheets("Data")
.range(Cells(1, iCol), Cells(iLastRow, iCol)) _
.AdvancedFilter Action:=xlFilterCopy _
, CopyToRange:=oSheet.range("A1") _
, Unique:=True
iRow = 2
Do While True
sValue = Trim(oSheet.Cells(iRow, 1))
If sValue = "" Then
If iEmptyValueCount > 0 Then
Exit Do
End If
iEmptyValueCount = iEmptyValueCount + 1
End If
aValue.Add sValue
iRow = iRow + 1
Loop
End Sub
'************************************************************
'* RemoveValueList()
'************************************************************
Sub RemoveValueList(ByRef aValue As Collection, aRemoveArray As Variant)
For i = LBound(aRemoveArray) To UBound(aRemoveArray)
sValue = aRemoveArray(i)
iMax = aValue.Count
For j = iMax To 0 Step -1
If aValue(j) = sValue Then
aValue.Remove (j)
Exit For
End If
Next j
Next i
End Sub
'************************************************************
'* CollectionToArray()
'************************************************************
Sub CollectionToArray(a() As Variant, c As Collection)
iSize = c.Count - 1
ReDim a(iSize)
For i = 0 To iSize
a(i) = c.Item(i + 1)
Next
End Sub
This code can certainly be improved in returning an Array of String but working with Array in VBA is not easy.
CAUTION: this code work only if you define a sheet named X because CopyToRange parameter used in AdvancedFilter() need an Excel Range !
It's a shame that Microfsoft doesn't have implemented this solution in adding simply a new enum as xlNotFilterValues ! ... or xlRegexMatch !
Alternative using VBA's Filter function
As an innovative alternative to #schlebe 's recent answer, I tried to use the Filter function integrated in VBA, which allows to filter out a given search string setting the third argument to False. All "negative" search strings (e.g. A, B, C) are defined in an array. I read the criteria in column A to a datafield array and basicly execute a subsequent filtering (A - C) to filter these items out.
Code
Sub FilterOut()
Dim ws As Worksheet
Dim rng As Range, i As Integer, n As Long, v As Variant
' 1) define strings to be filtered out in array
Dim a() ' declare as array
a = Array("A", "B", "C") ' << filter out values
' 2) define your sheetname and range (e.g. criteria in column A)
Set ws = ThisWorkbook.Worksheets("FilterOut")
n = ws.Range("A" & ws.Rows.Count).End(xlUp).row
Set rng = ws.Range("A2:A" & n)
' 3) hide complete range rows temporarily
rng.EntireRow.Hidden = True
' 4) set range to a variant 2-dim datafield array
v = rng
' 5) code array items by appending row numbers
For i = 1 To UBound(v): v(i, 1) = v(i, 1) & "#" & i + 1: Next i
' 6) transform to 1-dim array and FILTER OUT the first search string, e.g. "A"
v = Filter(Application.Transpose(Application.Index(v, 0, 1)), a(0), False, False)
' 7) filter out each subsequent search string, i.e. "B" and "C"
For i = 1 To UBound(a): v = Filter(v, a(i), False, False): Next i
' 8) get coded row numbers via split function and unhide valid rows
For i = LBound(v) To UBound(v)
ws.Range("A" & Split(v(i) & "#", "#")(1)).EntireRow.Hidden = False
Next i
End Sub
An option using AutoFilter
Option Explicit
Public Sub FilterOutMultiple()
Dim ws As Worksheet, filterOut As Variant, toHide As Range
Set ws = ActiveSheet
If Application.WorksheetFunction.CountA(ws.Cells) = 0 Then Exit Sub 'Empty sheet
filterOut = Split("A B C D E F G")
Application.ScreenUpdating = False
With ws.UsedRange.Columns("A")
If ws.FilterMode Then .AutoFilter
.AutoFilter Field:=1, Criteria1:=filterOut, Operator:=xlFilterValues
With .SpecialCells(xlCellTypeVisible)
If .CountLarge > 1 Then Set toHide = .Cells 'Remember unwanted (A, B, and C)
End With
.AutoFilter
If Not toHide Is Nothing Then
toHide.Rows.Hidden = True 'Hide unwanted (A, B, and C)
.Cells(1).Rows.Hidden = False 'Unhide header
End If
End With
Application.ScreenUpdating = True
End Sub
Here an option using a list written on some range, populating an array that will be fiiltered. The information will be erased then the columns sorted.
Sub Filter_Out_Values()
'Automation to remove some codes from the list
Dim ws, ws1 As Worksheet
Dim myArray() As Variant
Dim x, lastrow As Long
Dim cell As Range
Set ws = Worksheets("List")
Set ws1 = Worksheets(8)
lastrow = ws.Cells(Application.Rows.Count, 1).End(xlUp).Row
'Go through the list of codes to exclude
For Each cell In ws.Range("A2:A" & lastrow)
If cell.Offset(0, 2).Value = "X" Then 'If the Code is associated with "X"
ReDim Preserve myArray(x) 'Initiate array
myArray(x) = CStr(cell.Value) 'Populate the array with the code
x = x + 1 'Increase array capacity
ReDim Preserve myArray(x) 'Redim array
End If
Next cell
lastrow = ws1.Cells(Application.Rows.Count, 1).End(xlUp).Row
ws1.Range("C2:C" & lastrow).AutoFilter field:=3, Criteria1:=myArray, Operator:=xlFilterValues
ws1.Range("A2:Z" & lastrow).SpecialCells(xlCellTypeVisible).ClearContents
ws1.Range("A2:Z" & lastrow).AutoFilter field:=3
'Sort columns
lastrow = ws1.Cells(Application.Rows.Count, 1).End(xlUp).Row
'Sort with 2 criteria
With ws1.Range("A1:Z" & lastrow)
.Resize(lastrow).Sort _
key1:=ws1.Columns("B"), order1:=xlAscending, DataOption1:=xlSortNormal, _
key2:=ws1.Columns("D"), order1:=xlAscending, DataOption1:=xlSortNormal, _
Header:=xlYes, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
End With
End Sub
This works for me:
This is a criteria over two fields/columns (9 and 10), this filters rows with values >0 on column 9 and rows with values 4, 7, and 8 on column 10. lastrow is the number of rows on the data section.
ActiveSheet.Range("$A$1:$O$" & lastrow).AutoFilter Field:=9, Criteria1:=">0", Operator:=xlAnd
ActiveSheet.Range("$A$1:$O$" & lastrow).AutoFilter Field:=10, Criteria1:=Arr("4","7","8"), Operator:=xlFilterValues
Okay, I solved it.
I've smashed my head about this problem several times over the years, but I've solved it.
All we need to do is look at all the values that are actually IN the filter range, and if they're not on the list of values we want to filter out, we add them to the "Filter For this item" list.
To note about this code:
I wrote this to act on multiple sheets, and I'm not going to change that as I'm at work and don't have time. I'm sure you can figure it out.
I don't think you need to work in Option base 1... But I am, so if you run into issues... might be that.
Despite how many hundreds of thousands of times it's checking and rechecking the same arrays, it's remarkably fast.
I'm sure there is a way to redim KeepArray, but I didn't have time to consider it.
Option Explicit
Option Base 1
Sub FilterTable()
Dim WS As Worksheet
Dim L As Long
Dim I As Long
Dim N As Long
Dim tbl As ListObject
Dim tblName As String
Dim filterArray
Dim SrcArray
Dim KeepArray(1 To 5000) ' you might be able to figure out a way to redim this easiely later on.. for now I'm just oversizing it.
N = 0
filterArray = Array("FilterMeOut007", _
"FilterMeOut006", _
"FilterMeOut005", _
"FilterMeOut004", _
"FilterMeOut003", _
"FilterMeOut002", _
"FilterMeOut001")
For Each WS In ThisWorkbook.Worksheets
Debug.Print WS.Name
If Left(WS.Name, 4) = "AR -" Then
With WS
tblName = Replace(WS.Name, " ", "_")
Set tbl = WS.ListObjects(tblName)
SrcArray = tbl.ListColumns(1).DataBodyRange
For I = 1 To UBound(SrcArray, 1)
If Not ExistsInArray(KeepArray, SrcArray(I, 1)) _
And Not ExistsInArray(filterArray, SrcArray(I, 1)) Then
N = N + 1
KeepArray(N) = SrcArray(I, 1)
End If
Next I
tbl.DataBodyRange.AutoFilter Field:=1, Criteria1:=KeepArray, Operator:=xlFilterValues
End With
End If
Next WS
End Sub
Function ExistsInArray(arr, Val) As Boolean
Dim I As Long
ExistsInArray = False
For I = LBound(arr) To UBound(arr)
If arr(I) = Val Then
ExistsInArray = True
Exit Function
End If
Next I
End Function
Please let me know if you run into any errors with this as I'd like to stress test and debug it as much as possible in the future to make it as portable as possible. I picture using it a lot.
Please check this one for filtering out values in a range; It works.
Selection.AutoFilter field:=33, Criteria1:="<>Array(IN1R,IN2R,INDA)", Operator:=xlFilterValues
Actually, the above code did not work. Hence I give a loop to hide the entire row whenever the active cell has the value that I am searching for.
For each cell in selection
If cell.value = “IN1R” or cell.value = “INR2” or cell.value = “INDA” then
Else
Activecell.Entirerow.Hidden = True
End if
Next

Autofilter array criteria [duplicate]

My intention was to have the following code compile data from my "Low CPM 1" worksheet into an array and then filter my active worksheet based on this array. While the macro does seem to affect the filters, none of the values get filtered out. Any help on this matter would be greatly appreciated
Sub Macro1()
Dim CPM1Array(0 To 300) As Variant
For i = 2 To UBound(CPM1Array)
CPM1Array(i) = Sheets("Low CPM 1").Cells(i, 2).Value
Next i
ActiveSheet.Range("$A$1:$H$251").AutoFilter Field:=3, Criteria1:=("<>1 to Ubound(CPM1Array)"), Operator:=xlFilterValues
End Sub
There is no simple way with autofilter to achieve what you want. You cannot use Criteria1:="<>MyArray"
Alternative
We know which values we do not want. We can find out what are the values of the relevant column
Simply store the values of the relevant column in an array and then remove the unnecessary values from it by comparing it with the array which has values we do not want.
Remove blank cells from the array
Pass the final array to the autofilter.
In Action
Let's say our worksheet looks like as shown in the below image. I am taking an example of only 15 rows.
Code
Sub Sample()
Dim ws As Worksheet
Dim MyAr(1 To 5) As String
Dim tmpAr As Variant, ArFinal() As String
Dim LRow As Long
ReDim ArFinal(0 To 0)
Set ws = ActiveSheet
'~~> Creating an array of values which we do not want
For i = 1 To 5
MyAr(i) = i
Next i
With ws
'~~> Last Row of Col C sice you will filter on 3rd column
LRow = .Range("C" & .Rows.Count).End(xlUp).Row
'~~> Storing the values form C in the array
tmpAr = .Range("C2:C" & LRow).Value
'~~> Compare and remove values which we do not want
For i = 1 To LRow - 1
For j = 1 To UBound(MyAr)
If tmpAr(i, 1) = MyAr(j) Then tmpAr(i, 1) = ""
Next j
Next i
'~~> Remove blank cells from the array by copying them to a new array
For i = LBound(tmpAr) To UBound(tmpAr)
If tmpAr(i, 1) <> "" Then
ArFinal(UBound(ArFinal)) = tmpAr(i, 1)
ReDim Preserve ArFinal(0 To UBound(ArFinal) + 1)
End If
Next i
'~~> Filter on values which you want. Change range as applicable
.Range("$A$1:$H$15").AutoFilter Field:=3, Criteria1:=ArFinal, Operator:=xlFilterValues
End With
End Sub
Output

filter out multiple criteria using excel vba

I have 8 variables in column A, 1,2,3,4,5 and A, B, C.
My aim is to filter out A, B, C and display only 1-5.
I can do this using the following code:
My_Range.AutoFilter Field:=1, Criteria1:=Array("1", "2", "3","4","5"), _
Operator:=xlFilterValues
But what the code does is it filters variables 1 to 5 and displays them.
I want to do the opposite, but yielding the same result, by filtering out A, B, C and showing variables 1 to 5
I tried this code:
My_Range.AutoFilter Field:=1, Criteria1:=Array("<>A", "<>B", "<>C"), _
Operator:=xlFilterValues
But it did not work.
Why cant I use this code ?
It gives this error:
Run time error 1004 autofilter method of range class failed
How can I perform this?
I think (from experimenting - MSDN is unhelpful here) that there is no direct way of doing this. Setting Criteria1 to an Array is equivalent to using the tick boxes in the dropdown - as you say it will only filter a list based on items that match one of those in the array.
Interestingly, if you have the literal values "<>A" and "<>B" in the list and filter on these the macro recorder comes up with
Range.AutoFilter Field:=1, Criteria1:="=<>A", Operator:=xlOr, Criteria2:="=<>B"
which works. But if you then have the literal value "<>C" as well and you filter for all three (using tick boxes) while recording a macro, the macro recorder replicates precisely your code which then fails with an error. I guess I'd call that a bug - there are filters you can do using the UI which you can't do with VBA.
Anyway, back to your problem. It is possible to filter values not equal to some criteria, but only up to two values which doesn't work for you:
Range("$A$1:$A$9").AutoFilter Field:=1, Criteria1:="<>A", Criteria2:="<>B", Operator:=xlAnd
There are a couple of workarounds possible depending on the exact problem:
Use a "helper column" with a formula in column B and then filter on that - e.g. =ISNUMBER(A2) or =NOT(A2="A", A2="B", A2="C") then filter on TRUE
If you can't add a column, use autofilter with Criteria1:=">-65535" (or a suitable number lower than any you expect) which will filter out non-numeric values - assuming this is what you want
Write a VBA sub to hide rows (not exactly the same as an autofilter but it may suffice depending on your needs).
For example:
Public Sub hideABCRows(rangeToFilter As Range)
Dim oCurrentCell As Range
On Error GoTo errHandler
Application.ScreenUpdating = False
For Each oCurrentCell In rangeToFilter.Cells
If oCurrentCell.Value = "A" Or oCurrentCell.Value = "B" Or oCurrentCell.Value = "C" Then
oCurrentCell.EntireRow.Hidden = True
End If
Next oCurrentCell
Application.ScreenUpdating = True
Exit Sub
errHandler:
Application.ScreenUpdating = True
End Sub
I don't have found any solution on Internet, so I have implemented one.
The Autofilter code with criteria is then
iColNumber = 1
Dim aFilterValueArray() As Variant
Call ConstructFilterValueArray(aFilterValueArray, iColNumber, Array("A", "B", "C"))
ActiveSheet.range(sRange).AutoFilter Field:=iColNumber _
, Criteria1:=aFilterValueArray _
, Operator:=xlFilterValues
In fact, the ConstructFilterValueArray() method (not function) get all distinct values that it found in a specific column and remove all values present in last argument.
The VBA code of this method is
'************************************************************
'* ConstructFilterValueArray()
'************************************************************
Sub ConstructFilterValueArray(a() As Variant, iCol As Integer, aRemoveArray As Variant)
Dim aValue As New Collection
Call GetDistinctColumnValue(aValue, iCol)
Call RemoveValueList(aValue, aRemoveArray)
Call CollectionToArray(a, aValue)
End Sub
'************************************************************
'* GetDistinctColumnValue()
'************************************************************
Sub GetDistinctColumnValue(ByRef aValue As Collection, iCol As Integer)
Dim sValue As String
iEmptyValueCount = 0
iLastRow = ActiveSheet.UsedRange.Rows.Count
Dim oSheet: Set oSheet = Sheets("X")
Sheets("Data")
.range(Cells(1, iCol), Cells(iLastRow, iCol)) _
.AdvancedFilter Action:=xlFilterCopy _
, CopyToRange:=oSheet.range("A1") _
, Unique:=True
iRow = 2
Do While True
sValue = Trim(oSheet.Cells(iRow, 1))
If sValue = "" Then
If iEmptyValueCount > 0 Then
Exit Do
End If
iEmptyValueCount = iEmptyValueCount + 1
End If
aValue.Add sValue
iRow = iRow + 1
Loop
End Sub
'************************************************************
'* RemoveValueList()
'************************************************************
Sub RemoveValueList(ByRef aValue As Collection, aRemoveArray As Variant)
For i = LBound(aRemoveArray) To UBound(aRemoveArray)
sValue = aRemoveArray(i)
iMax = aValue.Count
For j = iMax To 0 Step -1
If aValue(j) = sValue Then
aValue.Remove (j)
Exit For
End If
Next j
Next i
End Sub
'************************************************************
'* CollectionToArray()
'************************************************************
Sub CollectionToArray(a() As Variant, c As Collection)
iSize = c.Count - 1
ReDim a(iSize)
For i = 0 To iSize
a(i) = c.Item(i + 1)
Next
End Sub
This code can certainly be improved in returning an Array of String but working with Array in VBA is not easy.
CAUTION: this code work only if you define a sheet named X because CopyToRange parameter used in AdvancedFilter() need an Excel Range !
It's a shame that Microfsoft doesn't have implemented this solution in adding simply a new enum as xlNotFilterValues ! ... or xlRegexMatch !
Alternative using VBA's Filter function
As an innovative alternative to #schlebe 's recent answer, I tried to use the Filter function integrated in VBA, which allows to filter out a given search string setting the third argument to False. All "negative" search strings (e.g. A, B, C) are defined in an array. I read the criteria in column A to a datafield array and basicly execute a subsequent filtering (A - C) to filter these items out.
Code
Sub FilterOut()
Dim ws As Worksheet
Dim rng As Range, i As Integer, n As Long, v As Variant
' 1) define strings to be filtered out in array
Dim a() ' declare as array
a = Array("A", "B", "C") ' << filter out values
' 2) define your sheetname and range (e.g. criteria in column A)
Set ws = ThisWorkbook.Worksheets("FilterOut")
n = ws.Range("A" & ws.Rows.Count).End(xlUp).row
Set rng = ws.Range("A2:A" & n)
' 3) hide complete range rows temporarily
rng.EntireRow.Hidden = True
' 4) set range to a variant 2-dim datafield array
v = rng
' 5) code array items by appending row numbers
For i = 1 To UBound(v): v(i, 1) = v(i, 1) & "#" & i + 1: Next i
' 6) transform to 1-dim array and FILTER OUT the first search string, e.g. "A"
v = Filter(Application.Transpose(Application.Index(v, 0, 1)), a(0), False, False)
' 7) filter out each subsequent search string, i.e. "B" and "C"
For i = 1 To UBound(a): v = Filter(v, a(i), False, False): Next i
' 8) get coded row numbers via split function and unhide valid rows
For i = LBound(v) To UBound(v)
ws.Range("A" & Split(v(i) & "#", "#")(1)).EntireRow.Hidden = False
Next i
End Sub
An option using AutoFilter
Option Explicit
Public Sub FilterOutMultiple()
Dim ws As Worksheet, filterOut As Variant, toHide As Range
Set ws = ActiveSheet
If Application.WorksheetFunction.CountA(ws.Cells) = 0 Then Exit Sub 'Empty sheet
filterOut = Split("A B C D E F G")
Application.ScreenUpdating = False
With ws.UsedRange.Columns("A")
If ws.FilterMode Then .AutoFilter
.AutoFilter Field:=1, Criteria1:=filterOut, Operator:=xlFilterValues
With .SpecialCells(xlCellTypeVisible)
If .CountLarge > 1 Then Set toHide = .Cells 'Remember unwanted (A, B, and C)
End With
.AutoFilter
If Not toHide Is Nothing Then
toHide.Rows.Hidden = True 'Hide unwanted (A, B, and C)
.Cells(1).Rows.Hidden = False 'Unhide header
End If
End With
Application.ScreenUpdating = True
End Sub
Here an option using a list written on some range, populating an array that will be fiiltered. The information will be erased then the columns sorted.
Sub Filter_Out_Values()
'Automation to remove some codes from the list
Dim ws, ws1 As Worksheet
Dim myArray() As Variant
Dim x, lastrow As Long
Dim cell As Range
Set ws = Worksheets("List")
Set ws1 = Worksheets(8)
lastrow = ws.Cells(Application.Rows.Count, 1).End(xlUp).Row
'Go through the list of codes to exclude
For Each cell In ws.Range("A2:A" & lastrow)
If cell.Offset(0, 2).Value = "X" Then 'If the Code is associated with "X"
ReDim Preserve myArray(x) 'Initiate array
myArray(x) = CStr(cell.Value) 'Populate the array with the code
x = x + 1 'Increase array capacity
ReDim Preserve myArray(x) 'Redim array
End If
Next cell
lastrow = ws1.Cells(Application.Rows.Count, 1).End(xlUp).Row
ws1.Range("C2:C" & lastrow).AutoFilter field:=3, Criteria1:=myArray, Operator:=xlFilterValues
ws1.Range("A2:Z" & lastrow).SpecialCells(xlCellTypeVisible).ClearContents
ws1.Range("A2:Z" & lastrow).AutoFilter field:=3
'Sort columns
lastrow = ws1.Cells(Application.Rows.Count, 1).End(xlUp).Row
'Sort with 2 criteria
With ws1.Range("A1:Z" & lastrow)
.Resize(lastrow).Sort _
key1:=ws1.Columns("B"), order1:=xlAscending, DataOption1:=xlSortNormal, _
key2:=ws1.Columns("D"), order1:=xlAscending, DataOption1:=xlSortNormal, _
Header:=xlYes, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
End With
End Sub
This works for me:
This is a criteria over two fields/columns (9 and 10), this filters rows with values >0 on column 9 and rows with values 4, 7, and 8 on column 10. lastrow is the number of rows on the data section.
ActiveSheet.Range("$A$1:$O$" & lastrow).AutoFilter Field:=9, Criteria1:=">0", Operator:=xlAnd
ActiveSheet.Range("$A$1:$O$" & lastrow).AutoFilter Field:=10, Criteria1:=Arr("4","7","8"), Operator:=xlFilterValues
Okay, I solved it.
I've smashed my head about this problem several times over the years, but I've solved it.
All we need to do is look at all the values that are actually IN the filter range, and if they're not on the list of values we want to filter out, we add them to the "Filter For this item" list.
To note about this code:
I wrote this to act on multiple sheets, and I'm not going to change that as I'm at work and don't have time. I'm sure you can figure it out.
I don't think you need to work in Option base 1... But I am, so if you run into issues... might be that.
Despite how many hundreds of thousands of times it's checking and rechecking the same arrays, it's remarkably fast.
I'm sure there is a way to redim KeepArray, but I didn't have time to consider it.
Option Explicit
Option Base 1
Sub FilterTable()
Dim WS As Worksheet
Dim L As Long
Dim I As Long
Dim N As Long
Dim tbl As ListObject
Dim tblName As String
Dim filterArray
Dim SrcArray
Dim KeepArray(1 To 5000) ' you might be able to figure out a way to redim this easiely later on.. for now I'm just oversizing it.
N = 0
filterArray = Array("FilterMeOut007", _
"FilterMeOut006", _
"FilterMeOut005", _
"FilterMeOut004", _
"FilterMeOut003", _
"FilterMeOut002", _
"FilterMeOut001")
For Each WS In ThisWorkbook.Worksheets
Debug.Print WS.Name
If Left(WS.Name, 4) = "AR -" Then
With WS
tblName = Replace(WS.Name, " ", "_")
Set tbl = WS.ListObjects(tblName)
SrcArray = tbl.ListColumns(1).DataBodyRange
For I = 1 To UBound(SrcArray, 1)
If Not ExistsInArray(KeepArray, SrcArray(I, 1)) _
And Not ExistsInArray(filterArray, SrcArray(I, 1)) Then
N = N + 1
KeepArray(N) = SrcArray(I, 1)
End If
Next I
tbl.DataBodyRange.AutoFilter Field:=1, Criteria1:=KeepArray, Operator:=xlFilterValues
End With
End If
Next WS
End Sub
Function ExistsInArray(arr, Val) As Boolean
Dim I As Long
ExistsInArray = False
For I = LBound(arr) To UBound(arr)
If arr(I) = Val Then
ExistsInArray = True
Exit Function
End If
Next I
End Function
Please let me know if you run into any errors with this as I'd like to stress test and debug it as much as possible in the future to make it as portable as possible. I picture using it a lot.
Please check this one for filtering out values in a range; It works.
Selection.AutoFilter field:=33, Criteria1:="<>Array(IN1R,IN2R,INDA)", Operator:=xlFilterValues
Actually, the above code did not work. Hence I give a loop to hide the entire row whenever the active cell has the value that I am searching for.
For each cell in selection
If cell.value = “IN1R” or cell.value = “INR2” or cell.value = “INDA” then
Else
Activecell.Entirerow.Hidden = True
End if
Next

Creating a specific macro

I'm trying to create a macro using Excel 2007 for some data I've collected. What I need the macro do to is, search a column and find a certain number of consecutive zero's (60) and if there is 60 consecutive zero's delete them. Any advice or help would be really appreciated!
Is this what you are trying?
LOGIC:
Filter the range on the criteria
Store the address on the visible cells in a variable
Remove "$" which Excel automatically puts in the address
Check if the visible cell address is like "2:2" or "2:2,5:64"
Find the difference between the start row and end row
If difference is >= say 60 then clear contents.
CODE
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, times As Long, Col As Long, i As Long
Dim rRange As Range
Dim addr As String, MyArray() As String, tmpAr() As String, num As String
'~~> Change these as applicable
Set ws = ThisWorkbook.Sheets("Sheet1") '<~~ Sheet1
Col = 1 '<~~ Col A
num = "0" '<~~ Number to replace
times = 60 '<~~ Consecutive Cells with Numbers
'~~> Don't change anything below this
With ws
lRow = .Range(ReturnName(Col) & .Rows.Count).End(xlUp).Row
Set rRange = .Range(ReturnName(Col) & "1:" & ReturnName(Col) & lRow)
'~~> Remove any filters
.AutoFilterMode = False
'~~> Filter, offset(to exclude headers)
With rRange
.AutoFilter Field:=1, Criteria1:="=" & num
'~~> get the visible cells address
addr = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Address
End With
'~~> Remove any filters
.AutoFilterMode = False
addr = Replace(addr, "$", "")
'~~> Check if addr has multiple ranges
If InStr(1, addr, ",") Then
MyArray = Split(addr, ",")
'~~> get individual ranges
For i = LBound(MyArray) To UBound(MyArray)
tmpAr = Split(MyArray(i), ":")
'~~> If difference is >= times then clear contents
If Val(Trim(tmpAr(1))) - Val(Trim(tmpAr(0))) >= times - 1 Then
.Range(ReturnName(Col) & Trim(tmpAr(0)) & ":" & _
ReturnName(Col) & Trim(tmpAr(1))).ClearContents
End If
Next i
Else
tmpAr = Split(addr, ":")
If Val(Trim(tmpAr(1))) - Val(Trim(tmpAr(0))) >= times - 1 Then
.Range(ReturnName(Col) & Trim(tmpAr(0)) & ":" & _
ReturnName(Col) & Trim(tmpAr(1))).ClearContents
End If
End If
End With
End Sub
'~~~> Function to retrieve Col Names from Col Numbers
Function ReturnName(ByVal numb As Long) As String
ReturnName = Split(Cells(, numb).Address, "$")(1)
End Function
Though I have a feeling you are going to change the requirements after you run this...
Select all the cells you want to look at, then run this code:
Option Explicit
Sub deleteConsecutiveZeros()
Dim rng As Excel.Range
Dim countZeros As Long
Dim lastCellRow As Long
Dim iCurrentRow As Long
Set rng = Selection
lastCellRow = rng.Cells.SpecialCells(xlCellTypeLastCell).Row
For iCurrentRow = lastCellRow To 1 Step -1
If (countZeros >= 60) Then
ActiveSheet.Range(rng.Cells(iCurrentRow + 59, 1).Address, rng.Cells(iCurrentRow, 1).Address).EntireRow.Delete
countZeros = 0
End If
If (rng.Cells(iCurrentRow, 1).Value = 0 And rng.Cells(iCurrentRow, 1).Text <> vbNullString) Then
countZeros = countZeros + 1
Else
countZeros = 0
End If
Next
End Sub

Resources