Copy a Filtered Table - excel

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

Related

How to filter keywords in VBA, including keywords that may not be found?

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

VBA code: "select rows to delete except headers" (not working)

I have the following code which should simply select a range of rows and delete them. Unfortunately it deletes the headers as well, no matter how I change the range.
I tried to change the "rng" parameter without success.
Thank you for the feedback you can provide.
Sub delete_rows_range()
'Application.ScreenUpdating = False
Dim rng, Rng_del As Range
Dim leg As Range
Set leg = Worksheets("Sheet1").Range("aB1")
Set rng = Worksheets("Sheet1").Range("b1")
If Worksheets("Sheet1").AutoFilterMode = True Then
Worksheets("Sheet1").AutoFilter.ShowAllData
End If
rng.Select
rng.AutoFilter Field:=2, Criteria1:=leg
'rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.delete
rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Select
Worksheets("Sheet1").AutoFilterMode = False
End Sub
Your problem is that you are using a single cell as the range.
When you .Offset a single cell range, then use `xlCelTypeVisible.EntireRow.Delete
Excel selects every cell on the sheet and deletes them.
You really should clarify your range with a properly defined range object. e.g.
Dim ws As Worksheet, lRow As Long, rng As Range
Set ws = Worksheets("Sheet1")
lRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ws.Range("A1:AB" & lRow)
But if you want to use B1 as your rng you can replace your line, rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Select with this line...
rng.Range(Cells(2, 2), Cells(rng.Rows.Count, 2)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
You are trying to select from a single cell range.
You should do instead:
Sub delete_rows_range()
'Application.ScreenUpdating = False
Dim rng, Rng_del As Range
Dim leg As Range
Set leg = Worksheets("Sheet1").Range("AB1")
Set rng = Worksheets("Sheet1").Range("B1")
If Worksheets("Sheet1").AutoFilterMode = True Then
Worksheets("Sheet1").AutoFilter.ShowAllData
End If
rng.Select
rng.AutoFilter Field:=2, Criteria1:=leg
'rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.delete
Worksheets("Sheet1").UsedRange.SpecialCells(xlCellTypeVisible).Rows(2).Select
Worksheets("Sheet1").AutoFilterMode = False
End Sub

How can I have my loop search for a value rather than a string of words?

I have some data that has both words and values in cells and I am trying to delete the rows that don’t have values in the cells. My code works now if all of the numbers are negative but if there are positive numbers then my code won’t work. How do I fix this?
Sub tval
Dim s As Long
Dim LastRow As Long
S=2
LastRow= cells.find(“*”,[A1],,, xlByRows,xlPreviousRow).row
Do until s>LastRow
DoEvents
If InStr(1,Cells(s,4), “-“) > 0 Then
S=s+1
Else
Cells(s,4).EntireRow.Delete
LastRow=LastRow -1
End if
Loop
End sub
When deleting rows, you should always start from the end.
Sub tval
Dim s As Long
Dim LastRow As Long
LastRow= Cells(Rows.Count, 1).End(xlUp).Row
For s= LastRow to 2 Step -1
If Not IsNumeric(Cells(s,4)) then
Cells(s,4).EntireRow.Delete
End if
Next s
End sub
This should work for you:
Sub tgr()
Dim ws As Worksheet
Dim rTextConstants As Range
Dim rTextFormulas As Range
Dim rCombined As Range
Set ws = ActiveWorkbook.ActiveSheet
'Exclude row 1 so that only text values found in rows 2+ are found
With ws.Range("A2", ws.Cells(ws.Rows.Count, ws.Columns.Count))
On Error Resume Next 'prevent error if no cells found
Set rTextConstants = .SpecialCells(xlCellTypeConstants, xlTextValues)
Set rTextFormulas = .SpecialCells(xlCellTypeFormulas, xlTextValues)
On Error GoTo 0 'remove on error resume next condition
End With
If Not rTextConstants Is Nothing Then Set rCombined = rTextConstants
If Not rTextFormulas Is Nothing Then
If rCombined Is Nothing Then Set rCombined = rTextFormulas Else Set rCombined = Union(rCombined, rTextFormulas)
End If
If Not rCombined Is Nothing Then
rCombined.EntireRow.Delete
Else
MsgBox "No cells containing text found in sheet '" & ws.Name & "'", , "Error"
End If
End Sub
May I suggest a bit of a different approach:
Before:
Code:
Dim RNG1 As Range, RNG2 As Range
Option Explicit
Sub TestCase()
With ActiveWorkbook.Sheets(1)
Set RNG1 = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
If RNG1.SpecialCells(xlCellTypeConstants, 1).Count <> RNG1.Cells.Count Then
Set RNG2 = Application.Intersect(RNG1, RNG1.SpecialCells(xlCellTypeConstants, 2))
RNG2.EntireRow.Delete
End If
End With
End Sub
After:
You'll need to change this around to suit your range obviously. It should be a good starting point nonetheless.
You can also use AutoFilter to filter the numbers, and delete the visible cells to accomplish this task. The code accounts for a header row.
With ThisWorkbook.Sheets("Sheet1")
With .Range("A1").CurrentRegion
.AutoFilter
.AutoFilter Field:=4, Criteria1:="<>*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With
End With

How to delete numbers in Excel Filter

I have data from A to F column and I want to filter in E column and delete the entire row which contains # and only numbers. (Check image). I used the code and it works for #, but numbers not. In filter the 'Number filter' is not availble so i cant record in macro.
How to change the code? Help me, please.
Sub Macro3()
Dim ws As Worksheet
Dim rng1 As Range
Set ws = Sheets("Sheet1")
Set rng1 = ws.Range(ws.[A2], ws.Cells(Rows.Count, "F").End(xlUp))
With ActiveSheet
.AutoFilterMode = False
rng1.AutoFilter Field:=5, Criteria1:="#"
rng1.Offset(1, 0).EntireRow.Delete
.AutoFilterMode = False
End With
End Sub
You can use Criteria1:=">=0" to find all numbers.
rng1.AutoFilter Field:=5, Criteria1:=">=0", Operator:=xlAnd
Dim RowsToDelete As Range
On Error Resume Next
Set RowsToDelete = rng1.Resize(RowSize:=rng1.Rows.Count - 1).Offset(RowOffset:=1).SpecialCells(xlCellTypeVisible).EntireRow
On Error GoTo 0
If Not RowsToDelete Is Nothing Then RowsToDelete.Delete
Note:
rng1.Resize(RowSize:=rng1.Rows.Count - 1).Offset(RowOffset:=1)
removes the header from rng1 selection
.SpecialCells(xlCellTypeVisible).EntireRow
selects only the visible cells of the filtered range.

Runtime Error '1004':, Method 'Intersect' of object '_Global' failed

I am getting a runtime error 1004 if I'm not on the same page that the script is meant to run on, and I'd like to know why...
here is the code.
Option Explicit
Sub PO_Tracking()
Dim wsPOD As Worksheet
Dim wsPOT As Worksheet
Dim wsPOA As Worksheet
Dim cel As Range
Dim lastrow As Long, i As Long, Er As Long
Set wsPOD = Sheets("PO Data")
Set wsPOT = Sheets("PO Tracking")
Set wsPOA = Sheets("PO Archive")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
With wsPOD
'first bring columns F:G up to match their line
For Each cel In Intersect(.UsedRange, .UsedRange.Offset(5), .Columns(6))
If cel = vbNullString And cel.Offset(, -2) <> vbNullString Then
.Range(cel.Offset(1), cel.Offset(1, 1)).Copy cel
cel.Offset(1).EntireRow.Delete
End If
Next
'now fil columns A:D to match PO Date and PO#
For Each cel In Intersect(.UsedRange, .UsedRange.Offset(5), .Columns(1))
If cel = vbNullString And cel.Offset(, 5) <> vbNullString Then
.Range(cel.Offset(-1), cel.Offset(-1, 3)).Copy cel
End If
Next
'Blow away rows that are useless
lastrow = wsPOD.Range("A6").End(xlDown).Row
wsPOD.Range("M5:P5").Copy wsPOD.Range("M6:P" & lastrow)
Calculate
With Intersect(wsPOD.UsedRange, ActiveSheet.Columns("N"))
.AutoFilter 1, "<>Different"
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
With Intersect(wsPOD.UsedRange, ActiveSheet.Columns("P"))
.AutoFilter 1, "<>Full"
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
wsPOD.UsedRange.Copy Sheets.Add.Range("A1")
'Final Adjustments before transfering over to new sheet.
With ActiveSheet
.AutoFilterMode = False
Intersect(.UsedRange, .Columns("A")).Cut .Range("Q1")
Intersect(.UsedRange, .Columns("D")).Cut .Range("R1")
Intersect(.UsedRange, .Columns("C")).Cut .Range("S1")
Intersect(.UsedRange, .Columns("B")).Cut .Range("T1")
Intersect(.UsedRange, .Columns("G")).Cut .Range("U1")
Intersect(.UsedRange, .Columns("F")).Cut .Range("V1")
Intersect(.UsedRange, .Range("Q:V")).Copy wsPOT.Cells(Rows.Count, "B").End(xlUp).Offset(1)
.Delete
End With
lastrow = wsPOD.Cells(Rows.Count, "B").End(xlUp).Row
wsPOT.Range("R1:X1").Copy
wsPOT.Range("B3:H" & lastrow).PasteSpecial xlPasteFormats
wsPOT.Range("N2:O2").Copy wsPOT.Range("N3:O" & lastrow)
wsPOT.Range("P1:Q1").Copy wsPOT.Range("I3:J" & lastrow)
wsPOT.Range("K3:K" & lastrow).Borders.Weight = xlThin
End With
Application.CutCopyMode = False
End Sub
The error is here:
**With Intersect(wsPOD.UsedRange, ActiveSheet.Columns("N"))**
.AutoFilter 1, "<>Different"
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
You can't have an intersection of ranges on two sheets, so if ActiveSheet is not wsPOD, then
With Intersect(wsPOD.UsedRange, ActiveSheet.Columns("N"))
has to fail by definition.
EDIT ... and see #SiddharthRout's comment for the fix.
For why the error, see the answer by Doug Glancy.
In addition, for how to avoid it, use something like
Dim rng1 As Range, rng2 As Range
Set rng1 = wsPOD.UsedRange
Set rng2 = ActiveSheet.Columns("N")
If (rng1.Parent.Name = rng2.Parent.Name) Then
Dim ints As Range
Set ints = Intersect(rng1, rng2)
If (Not (ints Is Nothing)) Then
With ints
' Do your job
End With
End If
End If
It is typically good practice to verify an Intersection before using it.
to avoid the error one has to check for equality of the worksheet (myRange.Parent) like this:
if rng1.Parent is rng2.Parent then if Not Intersect( rng1, rng2 ) Is Nothing then _
'... your conditional code here ...
hint: the important thing to notice here is that you can't connect the two conditions with ... And ... since VBA evaluates all conditions and does not stop after evaluating the first even if it is False :-/
or make sure the range's worksheets are the same (e.g. ws1), meaning to explicitely specify/create/intersect your Range objects similar to this):
if Not Intersect( ws1.Range("A1:A2"), ws1.Range("A2:B2") ) Is Nothing then _
'... your conditional code here ...

Resources