Related
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
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
I have raw data which has a large number of columns. I want to extract cells in the first row which begin with Sum_Pop, for example Sum_Pop2_3,N,. I then want to input these strings into a summary sheet in row 4, starting at column 5. Can anybody help me with some VBA code for this problem?
The raw data has roughly 160 columns, and I only want to extract about 10-20 cells. I then want them to input onto the analysis sheet in order, so there are not any gaps between the cells, so it will create headers for yearly increase of population for each row.
I've attempted to use this code:
Private Sub ()
Dim qq As Integer
Dim I As Integer
For qq = 5 To 25
For I = 1 To 200
If Sheets("raw").Range("A" & I) Like "Sum_Pop*" Then
Sheets("raw").Range("A" & I) = Sheets("analysis").Range("R4C" & qq).Value
Else:
Next I
End If
Next qq
Next I
End Sub
Sub Macro1()
Dim ws as Worksheet, LastCol as Long, i as Long, MySel as Range
Set ws = ThisWorkbook.Sheets("raw")
With ws
LastCol= .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 1 to LastCol
If .Cells(1, i) Like "Sum_Pop*" Then
If MySel Is Nothing Then
Set MySel = .Cells(1, i)
Else
Set MySel = Union(MySel, .Cells(1, i))
End If
End If
Next i
End With
If Not MySel Is Nothing Then MySel.Copy _
Destination:=ThisWorkbook.Sheets.Add.Range("E4")
End Sub
I have a data table which is sorted on descending order in column F. I then need to copy the top 5 rows, but only data from Column A, B, D, and F (not the headers). See pictures.
Sub top5()
Sheets("Sheet1").Select
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
ActiveSheet.Range("$A$4:$T$321").AutoFilter Field:=3, Criteria1:="Dave"
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields. _
Clear
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add _
Key:=Range("F4:F321"), SortOn:=xlSortOnValues, Order:=xlDescending, _
DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' This copy-paste part does what its supposed to, but only for the specific
' cells. Its not generalised and I will have to repeat this operation
' several times for different people
Sheets("Sheet1").Select
Range("A3:B15").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A3").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Range("D3:D15").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("C3").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Range("F3:F15").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("D3").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
I thought about trying to adapt this snippet of code below using visible cells function, but I'm stuck and I can't find anything on the net which fits.
' This selects all rows (plus 1, probably due to offset), I only want parts of from the top 5.
Sheets("Sheet1").Select
ActiveSheet.Range("$A$4:$B$321").Offset(1, 0).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A3").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
ActiveSheet.Range("$D$4:$D$321").Offset(1, 0).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Sheet2").Select
Range("C3").Select
ActiveSheet.Paste
I hope my example makes sense and I really appreciate your help!
Note: The heading names are only the same in the two tables to show that the data is the same. The headers are NOT supposed to be copied. In addition, there is an extra column/white space in the second table. A solution should include this.
Firstly a few helpful points:
You should refer to worksheets by there Code Name to avoid renaming issues.
If you want to work with VBA then my advice is to avoid merged cells like the plague. They cause havoc with code. If possible use format cells - alignment - horizontal - centre accross selection
I also advise avoiding loops wherever possible and take advantage of excels built in functions instead as a good practice exercise.
Here is my solution. Keep it simple. If you need further help let me now.
Sub HTH()
Dim rCopy As Range
With Sheet1.AutoFilter.Range
'// Set to somewhere blank and unused on your worksheet
Set rCopy = Sheet1.Range("A" & Rows.Count - (.Rows.Count))
.SpecialCells(xlCellTypeVisible).Copy rCopy
End With
With rCopy.Offset(1).Resize(5) '// Offset to avoid the header
.Resize(, 2).Copy Sheet2.Range("A5")
.Offset(, 3).Resize(, 1).Copy Sheet2.Range("D5")
.Offset(, 5).Resize(, 1).Copy Sheet2.Range("F5")
.CurrentRegion.Delete xlUp '// Delete the tempory area
End With
Set rCopy = Nothing
End Sub
A quick way to do this is to use Union and Intersect to only copy the cells that you want. If you are pasting values (or the data is not a formula to start), this works well. Thinking about it, it builds a range of columns to keep using Union and then Intersect that with the first 5 rows of data with 2 header rows. The result is a copy of only the data you want with formatting intact.
Edit only process visible rows, grabbing the header, and then the first 5 below the header rows
Sub CopyTopFiveFromSpecificColumns()
'set up the headers first to keep
Dim rng_top5 As Range
Set rng_top5 = Range("3:4").EntireRow
Dim int_index As Integer
'start below the headers and keep all the visible cells
For Each cell In Intersect( _
ActiveSheet.UsedRange.Offset(5), _
Range("A:A").SpecialCells(xlCellTypeVisible))
'add row to keepers
Set rng_top5 = Union(rng_top5, cell.EntireRow)
'track how many items have been stored
int_index = int_index + 1
If int_index >= 5 Then
Exit For
End If
Next cell
'copy only certain columns of the keepers
Intersect(rng_top5, _
Union(Range("A:A"), _
Range("B:B"), _
Range("D:D"), _
Range("F:F"))).Copy
'using Sheet2 here, you can set to wherever, works if data is not formulas
Range("Sheet2!A1").PasteSpecial xlPasteAll
'if the data contains formulas, use this route
'Range("Sheet2!A1").PasteSpecial xlPasteValues
'Range("Sheet2!A1").PasteSpecial xlPasteFormats
End Sub
Here is the result I get from some dummy data set up in the same ranges as the picture above.
Sheet1 with copied range visible
Sheet2 with pasted data
The first part of your question, selecting the top5 visible cells, is relatively easy, the copying and pasting is where the trouble are. You see, you cannot paste a range, even if it is not uniform, into non uniform range. So you'll need to write your own Paste function.
Part 1 - Getting the Top5 rows
I used a similar technique to #Byron's. Notice that this is merely a function returning a Range object and accepting a String, which represents your non-uniform range (you can change the parameter type to Range if you wish).
Function GetTop5Range(SourceAddress As String) As Range
Dim rngSource As Range
Dim rngVisible As Range
Dim rngIntersect As Range
Dim rngTop5 As Range
Dim i As Integer
Dim cell As Range
Set rngSource = Range(SourceAddress)
Set rngVisible = rngSource.SpecialCells(xlCellTypeVisible).Cells
Set rngIntersect = Intersect(rngVisible, rngVisible.Cells(1, 1).EntireColumn)
i = 1
For Each cell In rngIntersect
If i = 1 Then
Set rngTop5 = cell.EntireRow
i = i + 1
ElseIf i > 1 And i < 6 Then
Set rngTop5 = Union(rngTop5, cell.EntireRow)
i = i + 1
Else
Exit For
End If
Next cell
Set GetTop5Range = Intersect(rngTop5, rngVisible)
End Function
Part 2 - Creating your own pasting function
Because Excel always pastes your copied range as uniform, you need to do it yourself. This method essentially breaks down your source region to columns and pastes them individually. The method accepts parameter SourceRange of type Range , which is meant to by your Top5 range, and a TopLeftCornerRange of type Range, which represents the target cell of your pasting.
Sub PasteRange(SourceRange As Range, TopLeftCornerRange As Range)
Dim rngColumnRange As Range
Dim cell As Range
Set rngColumnRange = Intersect(SourceRange, SourceRange.Cells(1, 1).EntireRow)
For Each cell In rngColumnRange
Intersect(SourceRange, cell.EntireColumn).Copy
TopLeftCornerRange.Offset(0, cell.Column - 1).PasteSpecial xlPasteValuesAndNumberFormats
Next cell
Application.CutCopyMode = False
End Sub
Part 3 - Running the procedure
Sub Main()
PasteRange GetTop5Range("A2:B33,D2:D33"), Range("A35")
End Sub
That's it.
In my project, I had source data in Columns A, B and D like you did and the results are pasted to range beginning at A35.
Result:
Hope this helps!
While it may simply be easier to loop through the first five visible rows, I used application.evaluate to process a worksheet-style formula that returned the row number of the fifth visible record.
Sub sort_filter_copy()
Dim lr As Long, lc As Long, flr As Long, rws As Long, v As Long
Dim sCRIT As String
Dim vCOLs As Variant, vVALs As Variant
Dim bCopyFormulas As Boolean, bSort2Keys As Boolean
bCopyFormulas = True
bSort2Keys = False
sCRIT = "dave"
vCOLs = Array(1, 2, 4, 6)
With Sheet1
lr = .Cells(Rows.Count, 1).End(xlUp).Row
lc = .Cells(4, Columns.Count).End(xlToLeft).Column
With .Cells(5, 1).Resize(lr - 4, lc)
'sort on column F as if there was no header
If bSort2Keys Then
.Cells.Sort Key1:=.Columns(6), Order1:=xlDescending, _
Key2:=.Columns(7), Order2:=xlDescending, _
Orientation:=xlTopToBottom, Header:=xlNo
Else
.Cells.Sort Key1:=.Columns(6), Order1:=xlDescending, _
Orientation:=xlTopToBottom, Header:=xlNo
End If
With .Offset(-1, 0).Resize(.Rows.Count + 1, .Columns.Count)
.AutoFilter
.AutoFilter field:=3, Criteria1:=sCRIT
With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
rws = Application.Min(5, Application.Subtotal(103, .Columns(3)))
If CBool(rws) Then
flr = Application.Evaluate("=small(index(rows(5:" & lr & ") + ('" & Sheet1.Name & "'!C5:C" & lr & "<>" & Chr(34) & sCRIT & Chr(34) & ")*1e99, , ), " & rws & ")")
For v = LBound(vCOLs) To UBound(vCOLs)
If .Columns(vCOLs(v)).Cells(1).HasFormula And bCopyFormulas Then
Sheet2.Cells(3, vCOLs(v)).Resize(5, 1).FormulaR1C1 = _
.Columns(vCOLs(v)).Cells(1).FormulaR1C1
Else
.Columns(vCOLs(v)).Resize(flr - 4, 1).Copy _
Destination:=Sheet2.Cells(3, vCOLs(v))
End If
Next v
End If
End With
.AutoFilter
End With
'uncomment the next line if you want to return to a standard ascending sort on column A
'.Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlNo
End With
End With
End Sub
All options are set just below the variable declarations. Your sample images seemed to indicate that you used a two key sort so I coded for that optionally. If you want to bring in any formulas as formulas, that option is there. The filter criteria and the columns to copy are assigned to their respective vars as well.
My sample workbook is available on my public DropBox at:
Sort_Filter_Copy_from_Top_5.xlsb
Try this:
Sub GetTopFiveRows()
Dim table As Range, cl As Range, cnt As Integer
Set table = Worksheets("Sheet1").Range("A2:A10").SpecialCells(xlCellTypeVisible)
cnt = 1
With Worksheets("Sheet2")
For Each cl In table
If cnt <= 5 Then
.Range("A" & cnt) = cl
.Range("B" & cnt) = cl.Offset(0, 1)
.Range("D" & cnt) = cl.Offset(0, 3)
.Range("F" & cnt) = cl.Offset(0, 5)
cnt = cnt + 1
Else
Exit Sub
End If
Next cl
End With
End Sub
First a reference is set to only visible rows in the entire table (you'll need to update the range reference)
Then we loop over the visible range, copy to sheet 2, and stop when 5 records (i.e. the top five) have been copied
First Unmerge the cells then use this code, very similar to some of the other suggestions.
Sub Button1_Click()
Dim sh As Worksheet
Dim Rws As Long, Rng As Range, fRng As Range, c As Range, fRw As Long
Set sh = Sheets("Sheet2")
Rws = Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = Range(Cells(4, 1), Cells(Rws, "T")) 'unmerge all the headers
Rng.AutoFilter Field:=3, Criteria1:="Dave"
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields. _
Clear
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add _
Key:=Range("F4:F321"), SortOn:=xlSortOnValues, Order:=xlDescending, _
DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Set fRng = Range(Cells(5, 1), Cells(Rws, 1)).SpecialCells(xlCellTypeVisible)
x = 0
For Each c In fRng.Cells
If x = 5 Then Exit Sub
fRw = sh.Cells(Rows.Count, "A").End(xlUp).Row + 1
sh.Range(sh.Cells(fRw, 1), sh.Cells(fRw, 2)).Value = Range(Cells(c.Row, 1), Cells(c.Row, 2)).Value
sh.Cells(fRw, 4).Value = Cells(c.Row, 4).Value
sh.Cells(fRw, 6).Value = Cells(c.Row, 6).Value
x = x + 1
Next c
End Sub
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