I recorded this macro where I make 3 filters, (by status, by substatus, and by country) once completed I want to save the results in a new spreadsheet with a custom name, the issue is when any of the option filter does not exist.
for example, if "costa rica" does not exist in the selection I get and weird result, in the event costa rica does not exist I would like to still create the new file but only copy and paste fist row of the original file into the new file.
Please help.
Sub filtrado()
ActiveSheet.ListObjects("SEGUIMIENTO").Range.AutoFilter Field:=2, Criteria1 _
:="Closed"
ActiveSheet.ListObjects("SEGUIMIENTO").Range.AutoFilter Field:=3, Criteria1 _
:=Array("In Progress", "Pending", "Pending Customer", "Updated by Customer"), _
Operator:=xlFilterValues
ActiveSheet.ListObjects("SEGUIMIENTO").Range.AutoFilter Field:=5, Criteria1 _
:="Costa Rica"
Cells.Select
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Paste
End Sub
You need to check if there are any visible rows so that you can copy the data.
Sub filtrado2()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim ol As ListObject: Set ol = ws.ListObjects("SEGUIMIENTO")
Dim olCol As Integer
Dim srcRng As Range, dstRng As Range
' filter column 2
olCol = ol.ListColumns("Column2").Index
ol.Range.AutoFilter Field:=olCol, Criteria1:="Closed"
' filter column 3
olCol = ol.ListColumns("Column3").Index
ol.Range.AutoFilter Field:=olCol, Criteria1 _
:=Array("In Progress", "Pending", "Pending Customer", "Updated by Customer"), _
Operator:=xlFilterValues
' filter column 5
olCol = ol.ListColumns("Column5").Index
ol.Range.AutoFilter Field:=5, Criteria1:="Costa Rica1"
' check visible rows
On Error Resume Next
Dim olRowsVisible As Integer
olRowsVisible = ol.ListColumns(1).DataBodyRange.SpecialCells(xlCellTypeVisible).Count
On Error GoTo 0
' copy only if any rows visible
If olRowsVisible > 0 Then
Set srcRng = Range.SpecialCells(xlCellTypeVisible) ' copies the table header and visible rows
Set dstRng = ws.Range("N1")
srcRng.Copy dstRng
Application.CutCopyMode = False
End If
End Sub
Related
I'm still learning VBA and am wondering if there's a way to run a VLOOKUP in a filtered range.
For example, in the code below, after I filter the data, the first row with data is A4.
However, I have to manually specify that the first row of data is in A4.
My question is whether it's possible so the macro detects the first row of data itself instead of me having to specify.
I've read about potentially using SpecialCells.
I am trying to do this as the datasets I receive change daily, so the first filtered row being A4 today might be A15 or whatever tomorrow.
Thanks
Range("A4").Select '/have to specify range here
Dim formul As String
formul = "=VLOOKUP(C2,Sheet2!A:B,2,0)"
Range("A4:A" & Cells(Rows.Count, 1).End(xlUp).Row) = [formul] '/also specify range here
'''
edit: code with SpecialCells:
''' vba
Range("A1").Select '/have to specify range here
Dim formul As String
formul = "=VLOOKUP(C1,Sheet2!A:B,2,0)"
Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible) = [formul] '/also specify range here
'''
Formula To Filtered Cells
This will filter column C and write formulas to the filtered cells in column A.
Option Explicit
Sub FormulaToFilteredCells()
Const sName As String = "Sheet2"
Const dName As String = "Sheet1"
Const dLookupColumn As Long = 1
Const dCriteriaColumn As Long = 3
Const dCriteria As String = "Yes"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
If dws.FilterMode Then dws.ShowAllData ' remove previous filter
Dim drg As Range ' Destination Table Range (has headers)
Set drg = dws.Range("A1").CurrentRegion.Columns(dCriteriaColumn)
Dim ddrg As Range ' Destination Data Range (no headers)
Set ddrg = drg.Resize(drg.Rows.Count - 1).Offset(1)
Dim dcOffset As Long: dcOffset = dLookupColumn - dCriteriaColumn
drg.AutoFilter 1, dCriteria
Dim dvdrg As Range ' Destination Visible Data Range
On Error Resume Next
Set dvdrg = ddrg.SpecialCells(xlCellTypeVisible).Offset(, dcOffset)
On Error GoTo 0
dws.AutoFilterMode = False
If dvdrg Is Nothing Then Exit Sub ' no filtered cells
dvdrg.Formula = "=VLOOKUP(" & dvdrg.Cells(1).Offset(, -dcOffset) _
.Address(0, 0) & ",'" & dName & "'!A:B,2,0)"
End Sub
Working with filtered data is possible with array formulas as shown here, here and here.
Why don't you copy the filtered data to a new Worksheet?
And work with vlookup on the filtered data in the 2nd Worksheet?
Sample Data: Wikipedia => List_of_countries_by_population
Sub FilterTable_and_Copy()
'Prepare Sheet2
If Sheets(2).Name <> "Filtered Data" Then
Sheets.Add After:=Sheets(1)
Sheets(2).Name = "Filtered Data"
End If
Sheets(2).Columns("A:G").ClearContents
'The Data is prepared in the Table "myTable"
'ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$F$100"), , _
' xlYes).Name = "myTable"
'Filter Data
Sheets(1).Select
ActiveSheet.Range("myTable").AutoFilter Field:=2, Criteria1:="Asia"
'Copy Filtered Data to Sheet2
Range("myTable").Copy
Sheets(2).Select
Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'Copy Header
Sheets(1).Select
Rows("1:1").Copy
Sheets(2).Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'Format Columns Width
Columns("A:F").ColumnWidth = 30
Columns("A:F").EntireColumn.AutoFit
Range("G1").Select
'Create Table "Table_FilteredData"
Sheets(2).ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , _
xlYes).Name = "Table_FilteredData"
'Correct Formatting Issue
Dim myRange As Range
With Sheets(2).ListObjects("Table_FilteredData")
Set myRange = .Range
.Unlist
End With
With myRange
.Interior.ColorIndex = xlColorIndexNone
.Font.ColorIndex = xlColorIndexAutomatic
.Borders.LineStyle = xlLineStyleNone
End With
Sheets(2).ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , _
xlYes).Name = "Table_FilteredData"
Sheets(2).ListObjects(1).TableStyle = "TableStyleMedium3"
End Sub
Data filtered for "region = Asia":
My goal is to copy and paste rows that meet a certain criteria into a table in another workbook.
My VBA works perfectly except for it pastes in the empty cell below the table. Not in the empty cells below the headers within the table.
PS. I know using select is generally frowned upon, but I needed to use fairly basic syntax so that if the next person needs to modify this and is unfamiliar with VBA they can.
Sub Export()
Sheets("Export Format").Select
Cells(13, "D").Calculate
With Range("A1", Cells(Rows.Count, "L").End(xlUp)) 'reference its column A:G cells from row 1 (header) down to last not empty one in column "A"
.AutoFilter Field:=6, Criteria1:="<>0" ' filter referenced cells on 6th column with everything but "0" content
If Application.WorksheetFunction.Subtotal(103, .Columns(1)) > 1 Then
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy ' copy filtered cells skipping headers
With Workbooks.Open(Filename:="Z:\Tracking\Database.xlsx").Sheets("Sheet1") 'open wanted workbook and reference its wanted sheet
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False 'paste filtered cells in referenced sheet from ist column A first empty cell after last not empty one
.Parent.Close True 'Save and closes referenced workbook
End With
Application.CutCopyMode = False
End If
End With
On Error Resume Next
Sheets("Export Format").ShowAllData 'Clears Filters
On Error GoTo 0
Sheets("Export Format").Select 'Brings back to Main request sheet
End Sub
Try using a property of the table such as InsertRowRange
Sub Export()
Const DBFILE = "Z:\Tracking\Database.xlsx"
Dim wb As Workbook, wbDB As Workbook
Dim ws As Worksheet, tbl As ListObject
Dim rngFilter As Range, x, rng As Range
Set wb = ThisWorkbook
Set ws = wb.Sheets("Export Format")
x = Application.WorksheetFunction.Subtotal(103, ws.Columns(1))
If x <= 1 Then
ws.Select
Exit Sub
End If
' set filter range
With ws
.Range("D13").Calculate
' column A:L cells from row 1 (header)
' down to last not empty one in column "A"
Set rngFilter = .Range("A1", .Cells(Rows.Count, "L").End(xlUp))
End With
' open wanted workbook and reference its wanted sheet
Set wbDB = Workbooks.Open(DBFILE)
With wbDB.Sheets("Sheet1")
Set tbl = .ListObjects("Table1")
If tbl.InsertRowRange Is Nothing Then
Set rng = tbl.ListRows.Add.Range
Else
Set rng = tbl.InsertRowRange
End If
End With
' filter on 6th column with everything but "0" content
With rngFilter
.AutoFilter Field:=6, Criteria1:="<>0"
' copy filtered cells skipping headers
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
'paste filtered cells in referenced sheet
'from ist column A first empty cell after last not empty one
rng.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With
wbDB.Close True 'Save and closes referenced workbook
ws.AutoFilterMode = False
ws.Select 'Brings back to Main request sheet
MsgBox "Ended"
End Sub
I want to filter a report that may or may not have five keywords in Column B (red, blue, orange, green and yellow) These keywords are associated with numbers in a different column
I want to take the sum of the column associated with each keyword on the generated report
However, the report may or may not have all five keywords; day over day may be different, with or without yellow for instance
I took the sum of the first keyword (a criterion) in Column C to paste elsewhere and it works!
But once I search for the second keyword an error occurs : This can't be applied to a single cell, select a single cell in a range (Run-time error 1004) . Any thoughts?
Second question is how do set my range (C2:C1000) and (B2:B1000) and for all filtered numbers in column C and keywords in column B, since I can have over 1000 rows or rows whose location is beyond 1000
Set rng = ws.Range("C1:C" & lastrow) 'but to no avail
Sub filterVBA()
Dim lastrow As Long
Dim visibleTotal As Long
Dim ws As Worksheet
Dim rng As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
Set rng = ws.Range("C2:C1000")
Columns("B:B").Select
Selection.AutoFilter
ActiveSheet.Range("B2:B1000").AutoFilter Field:=1, Criteria1:="red"
visibleTotal = Application.WorksheetFunction.Sum(rng.SpecialCells(xlCellTypeVisible))
Windows("Book6").Activate
Range("A1").Value = visibleTotal
Columns("B:B").Select
Selection.AutoFilter
ActiveSheet.Range("B2:B1000").AutoFilter Field:=1, Criteria1:="blue"
Windows("Book6").Activate
Range("A2").Value = visibleTotal
End Sub
There are a number of issues here.
Use of Select gives unexpected results (the second Filter will be applied to Windows("Book6")). Use Variables to reference the sheets and ranges.
Resetting the AutoFilter is fragile, if one doesn't already exists it will actually set a filter. Detect if a Filter exists before clearing it.
Clean up range selection.
Missing visibleTotal = after second filter
Sub filterVBA()
Dim visibleTotal As Long
Dim wsTable As Worksheet
Dim wsReport As Worksheet
Dim rTable As Range
Dim rReport As Range
'Get reference to Table
Set wsTable = ThisWorkbook.Sheets("Sheet1")
With wsTable
Set rTable = .Range("B2", .Cells(.Rows.Count, "C").End(xlUp))
End With
'Get Reference to Reult sheet
Set wsReport = Application.Workbooks("Book6").ActiveSheet
Set rReport = wsReport.Cells(1, 1)
'Clear Filter if it exists
If wsTable.AutoFilterMode Then
rTable.AutoFilter
End If
'Set Filter
rTable.AutoFilter Field:=1, Criteria1:="red"
visibleTotal = Application.WorksheetFunction.Sum(rTable.Columns(2).SpecialCells(xlCellTypeVisible))
'Alternative formula
'visibleTotal = Application.WorksheetFunction.Subtotal(109, rTable.Columns(2))
'Report result
rReport.Value = visibleTotal
Set rReport = rReport.Offset(1, 0)
'Next Filter
rTable.AutoFilter Field:=1, Criteria1:="white"
visibleTotal = Application.WorksheetFunction.Sum(rTable.Columns(2).SpecialCells(xlCellTypeVisible))
rReport.Value = visibleTotal
Set rReport = rReport.Offset(1, 0)
End Sub
Note on why there is no Error Handling around SpecialCells
Because the range SpecialCells is applied to includes the header row, and a AutoFilter never hides the header, in this case SpecialCells will always return a result .
Thanks for your feedback Chris
I got my answer looking like this and works well:
Sub filterVBA()
Dim rng As Range
Dim ws As Worksheet
Dim visibleTotal As Long
Set ws = ThisWorkbook.Sheets(1)
Set rng = ws.Range("D:D")
If ws.FilterMode = True Then
ws.ShowAllData
End If
Application.ScreenUpdating = False
ws.Range("C:C").AutoFilter Field:=1, Criteria1:="Yellow"
visibleTotal = Application.WorksheetFunction.Sum(rng.SpecialCells(xlCellTypeVisible))
Windows("Book6").Activate
Range("A1").Value = visibleTotal
ws.Range("C:C").AutoFilter Field:=1, Criteria1:="Red"
visibleTotal = Application.WorksheetFunction.Sum(rng.SpecialCells(xlCellTypeVisible))
Windows("Book6").Activate
Range("A5").Value = visibleTotal
ws.Range("C:C").AutoFilter Field:=1, Criteria1:="Green"
visibleTotal = Application.WorksheetFunction.Sum(rng.SpecialCells(xlCellTypeVisible))
Windows("Book6").Activate
Range("A10").Value = visibleTotal
ws.Range("C:C").AutoFilter Field:=1, Criteria1:="Blue"
visibleTotal = Application.WorksheetFunction.Sum(rng.SpecialCells(xlCellTypeVisible))
Windows("Book6").Activate
Range("A15").Value = visibleTotal
If ws.FilterMode = True Then
ws.ShowAllData
End If
Application.ScreenUpdating = True
End Sub
Trying to copy a filtered table and paste the results to the bottom of another table.
With RollupWeekSheet
sh1Col = .Range("Table1").Cells(1).Column
LastRollupWeekRow = .Cells(.Rows.Count, sh1Col).End(xlUp).Row
End With
Dim ComboWeekTable As ListObject
Set ComboWeekTable = ComboWeekSheet.ListObjects("Table1")
Dim RollupTimeStamp As Date
RollupTimeStamp = RollupWeekSheet.Range("B3").Value
With ComboWeekTable
.Range.AutoFilter Field:=16, Criteria1:=">" & RollupTimeStamp
.DataBodyRange.Copy
End With
With RollupWeekSheet
.Cells(LastRollupWeekRow + 1, sh1Col).PasteSpecial xlPasteValues
ComboWeekTable.Range.AutoFilter Field:=1
Application.CutCopyMode = False
Application.ScreenUpdating = True
End With`
With ComboWeekSheet
If .AutoFilterMode Then
.AutoFilterMode = False
End If
End With
It keeps highlighting the ".Autofilter" located under my "With ComboWeekTable" line and saying "Invalid use of property", but I don't know why. Please help.
It's a case of getting to the correct properties of the ListObject
Assuming you want just the filtered data rows (and not the header):
With ComboWeekTable
.Range.AutoFilter Field:=4, Criteria1:=">" & RollupTimeStamp
.DataBodyRange.Copy
End With
Unlike SpecialCells this still works if the filter returns no rows (no error, doesn't paste anything), so no need for error trapping
Demo
Sub Demo()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lo As ListObject
Set ws1 = ActiveSheet
Set ws2 = ws1.Parent.Worksheets(ws1.Index + 1)
Set lo = ws1.ListObjects(1)
If lo.AutoFilter Is Nothing Then lo.Range.AutoFilter
lo.ShowAutoFilterDropDown = True
With lo
.Range.AutoFilter Field:=1, Criteria1:="=2"
If Application.Aggregate(3, 5, lo.ListColumns(1).DataBodyRange) > 0 Then 'Count All, ignoring hidden rows
.DataBodyRange.Copy
ws2.Range("D5").PasteSpecial xlPasteValues
End If
lo.AutoFilter.ShowAllData ' clear filter
End With
End Sub
Before running Demo
After running Demo
EDITED to match your setup. This worked for me in testing:
Sub Tester()
Dim rngPaste As Range, ComboWeekTable As ListObject
Dim RollupTimeStamp As Date
'find the paste position
With RollupWeekSheet.ListObjects("Table2").DataBodyRange
Set rngPaste = .Rows(.Rows.Count).Cells(1).Offset(1, 0)
End With
Set ComboWeekTable = ComboWeekSheet.ListObjects("Table1")
RollupTimeStamp = RollupWeekSheet.Range("B3").Value
With ComboWeekTable.DataBodyRange
.AutoFilter Field:=16, Criteria1:=">" & RollupTimeStamp
On Error Resume Next '<< ignore run-time error if no rows visible
.SpecialCells(xlCellTypeVisible).Copy rngPaste
On Error GoTo 0 '<< stop ignoring errors
.AutoFilter
End With
ComboWeekTable.Range.AutoFilter Field:=1
End Sub
I would like to add AutoFilter Criteria to my excel table in separate Subs.
What I have at the moment looks a little something like this
.AutoFilter Field:=deviceTypeColumnId, Criteria1:=[dScenarioIndependent], Operator:=xlOr, _
Criteria2:=[dSmartphoneDeviceType]
What I would like to have is a method to first filter by Criteria1, and then, in another Sub, add Criteria2 to the existing AutoFilter. To my mind, it should look something like this:
Sub firstSub
.AutoFilter Field:=deviceTypeColumnId, Criteria1:=[dScenarioIndependent]
end sub
Sub secondSub
.AutoFilter mode:=xlAddCriteria, Field:=deviceTypeColumnId, Criteria1:=[dSmartphoneDeviceType]
'I know that mode doesn't exist, but is there anything like that?
end sub
Do you know any way to achieve this?
There isn't, that I know of, a way of "adding on" criteria to a filter which has previously been applied.
I have produced a work-around, which would work for what you are attempting to do. You will just have to add on scenarios to the select case statement, going up to the maximum number of filters which you will want to have.
EDIT: what it does; copy the filtered column to a new worksheet, and remove duplicates on that column. You're then left with the values which have been used to filter the column. Assign the values to an array, and then apply the number of elements of the array as a filter on the column, whilst including the new value you wish to filter on.
EDIT 2: added in a function to find the last row for when a table is already filtered (we want the last row, not the last visible row).
Option Explicit
Sub add_filter()
Dim wb As Workbook, ws As Worksheet, new_ws As Worksheet
Dim arrCriteria() As Variant, strCriteria As String
Dim num_elements As Integer
Dim lrow As Long, new_lrow As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("data")
Application.ScreenUpdating = False
lrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
ws.Range("A1:A" & lrow).Copy 'Copy column which you intend to add a filter to
Sheets.Add().Name = "filter_data"
Set new_ws = wb.Sheets("filter_data")
With new_ws
.Range("A1").PasteSpecial xlPasteValues
.Range("$A$1:$A$" & Cells(Rows.Count, 1).End(xlUp).Row).RemoveDuplicates _
Columns:=1, Header:=xlYes 'Shows what has been added to filter
new_lrow = Cells(Rows.Count, 1).End(xlUp).Row
If new_lrow = 2 Then
strCriteria = .Range("A2").Value 'If only 1 element then assign to string
Else
arrCriteria = .Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row) 'If more than 1 element make array
End If
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
If new_lrow = 2 Then
num_elements = 1
Else
num_elements = UBound(arrCriteria, 1) 'Establish number elements in array
End If
lrow = last_row
Select Case num_elements
Case 1
ws.Range("$A$1:$A$" & lrow).AutoFilter 1, _
Array(strCriteria, "New Filter Value"), Operator:=xlFilterValues
Case 2
ws.Range("$A$1:$A$" & lrow).AutoFilter 1, _
Array(arrCriteria(1, 1), arrCriteria(2, 1), _
"New Filter Value"), Operator:=xlFilterValues
Case 3
ws.Range("$A$1:$A$" & lrow).AutoFilter 1, _
Array(arrCriteria(1, 1), arrCriteria(2, 1), _
arrCriteria(3, 1), "New Filter Value"), Operator:=xlFilterValues
End Select
Application.ScreenUpdating = True
End Sub
Function:
Function last_row() As Long
Dim rCol As Range
Dim lRow As Long
Set rCol = Intersect(ActiveSheet.UsedRange, Columns("A"))
lRow = rCol.Row + rCol.Rows.Count - 1
Do While Len(Range("A" & lRow).Value) = 0
lRow = lRow - 1
Loop
last_row = lRow
End Function
Hope this helps.