Apply advanced filter after autofilter - vba

I want to do two successive filtering; the first on dates which I use auto-filter and on the produced result I want to do advance-filter (because I have OR in mind).
So what I did first was to set a range variable to the unfiltered range.
Set rng = Range(ws.Cells(1, 1), ws.Cells(rowNos, colNos))
Then using auto-filter I filter for given dates.
rng.AutoFilter Field:=1, Criteria1:=">" & lDate
Since now some rows will be hidden, and I want to apply advanced filter, I made use of specialcells
rng.SpecialCells(xlCellTypeVisible).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=crt, CopyToRange:=thisWB.Worksheets("Sheet3").Range("A1"), _
Unique:=False
However I got an error in the last step "the command requires at least two rowa of data . . " I made sure that there were at least 100 rows which fit the criteria meaning that the error is not because of a lack of rows.
Please help me get the problem. Also if there's another way I can accomplish the task I'll be happy to change my codes. What I'm trying to do is for specific dates filter a table and then filter again for values on two columns (as is normally done with advanced filters).

It seems like .AdvancedFilter does not work on non-continuous ranges. The code below is a bit kludge-y, but worked for a little example I pulled together where I want to return observations that are > April 1st, 2014 where Foo = Yes and Bar = 7. My data sheet contains exactly one row that matches all those criteria.
Option Explicit
Sub FilterTwice()
Dim DataSheet As Worksheet, TargetSheet As Worksheet, _
ControlSheet As Worksheet, TempSheet As Worksheet
Dim DataRng As Range, ControlRng As Range, _
TempRng As Range
Dim lDate As Date
Dim LastRow As Long, LastCol As Long
'assign sheets for easy reference
Set DataSheet = ThisWorkbook.Worksheets("Sheet1")
Set ControlSheet = ThisWorkbook.Worksheets("Sheet2")
Set TargetSheet = ThisWorkbook.Worksheets("Sheet3")
'clear any previously-set filters
Call ClearAllFilters(DataSheet)
'assign data range
LastRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set DataRng = Range(DataSheet.Cells(1, 1), DataSheet.Cells(LastRow, LastCol))
'assign a control (or critieria) range for the advanced filter
Set ControlRng = Range(ControlSheet.Cells(1, 1), ControlSheet.Cells(2, 2))
'apply date filter
lDate = "4/1/2014"
With DataRng
.AutoFilter Field:=1, Criteria1:=">" & lDate
End With
'add a temporary sheet and copy the visible cells to create a continuous range
Set TempSheet = Worksheets.Add
DataRng.SpecialCells(xlCellTypeVisible).Copy
TempSheet.Range("A1").PasteSpecial Paste:=xlPasteAll
'assign temp range
LastRow = TempSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastCol = TempSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set TempRng = Range(TempSheet.Cells(1, 1), TempSheet.Cells(LastRow, LastCol))
'apply advanced filter to temp range and get obs where foo = yes and bar = 7
With TempRng
.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=ControlRng, _
CopyToRange:=TargetSheet.Range("A1"), Unique:=False
End With
'remove the temp sheet and clear filters on the data sheet
Application.DisplayAlerts = False
TempSheet.Delete
Application.DisplayAlerts = True
DataSheet.AutoFilterMode = False
End Sub
Sub ClearAllFilters(cafSheet As Worksheet)
With cafSheet
.AutoFilterMode = False
If .FilterMode = True Then
.ShowAllData
End If
End With
End Sub

Related

Trying Set Values Instead of copying and pasting

I have been able to modify most of my VBA procedures to set ranges to equal other ranges to avoid copy and paste. It has speed up my code incredibly. However, there is a few cases where I can't figure out how to not use copy and paste. Below is one example:
Dim Creation2 As Worksheet
Dim HoleOpener As Worksheet
Dim Dal As Range
Dim Lad As Range
Dim Pal As Range
Dim LastRow As Long
Dim ws As Worksheet
Dim fndList As Variant
Dim rplcList As Variant
Set HoleOpener = Worksheets("HoleOpener")
LastRow = HoleOpener.Range("C" & Rows.Count).End(xlUp).Row
On Error Resume Next
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Creation2" And ws.Name <> "BitInfoTable" And ws.Name <> "DailyBitInfoTable" And ws.Name <> "BitRunInfoTable" And ws.Name <> "HoleOpener" Then
Set Lad = ws.Cells.Find(What:="StartCopy", LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=True, SearchFormat:=False).Resize(21, 25).Copy
Sheets("HoleOpener").Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
End If
Next
When I search I can't find any examples of doing something similar to this without copy/paste.
You will simply need to swap the ranges I listed with your ranges in FoundRange and PasteRange and adjust the Resize to fit your needs ((21, 25)). You have to use .value here as well.
Here is a generic example of how to set two ranges equal to each other. Since your range is greater than one, you will need to ensure each range is of equal size in terms of rows and columns spanned.
Dim FoundRange As Range, PasteRange As Range
Set FoundRange = Range("A1:B10") 'Swap this for your found value ("Lad" in your code)
Set PasteRange = Range("C1").Resize(10, 2) 'Swap this for your destination value
PasteRange.Value = FoundRange.Value
Using the same logic as above & your code, the result will look something like this:
Dim Lad As Range, PasteRange As Range
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Creation2" And ws.Name <> "BitInfoTable" And ws.Name <> "DailyBitInfoTable" And ws.Name <> "BitRunInfoTable" And ws.Name <> "HoleOpener" Then
Set Lad = ws.Cells.Find(What:="StartCopy", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Resize(21, 25)
Set PasteRange = Sheets("HoleOpener").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(21, 25)
Destiation.Value = Lad.Value
End If
Next ws
Basically, you are finding a range that meets a specific criteria, copying that range and pasting it in a new range.
This is how I would solve it without using copy/paste:
Find range as you have done
Iterate all cells in range (by column or row)
Store value of each cell in a variable
Set value of destination cell to variable stored in Step 3
As you can guess, it will require a lot more code, so it really is a trade-off between spending time writing and maintaining more code or optimizing for performance

Excel VBA Sorting not sorting all columns

My code is sorting the Column A Numerically correctly and also info tied to it in column B-D but not Columns E-M which are qty values. So when I add a Stock # the Description, supplier and Part # all sort with the Stock #, but not any qty values. They just stay in the same row. I have data that needs to stay with the sorted stock # until Column X.
Sub Sorting()
Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Set sht = Sheet1
Set StartCell = Range("A9")
'Refresh UsedRange
Worksheets("Order Summary").UsedRange
'Find Last Row
LastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'Select Range
sht.Range("A9:A" & LastRow).Select
Range("A9:A" & LastRow).Sort _
Key1:=Range("A9"), Header:=xlYes
End Sub
Sub Sorting()
Application.ScreenUpdating = False
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range("A9")
ActiveSheet.Sort.SetRange Range("A9:X500")
ActiveSheet.Sort.Apply
Application.ScreenUpdating = True
End Sub

Count rows and filter and then delete filtered rows with VBA

Can any one tell me how to count the total number of rows in an Excel spreadsheet and then pass the value dynamically?
Instead of the value of 2691 for the last row, I want to pass lastRow variable when setting the filter. Then I want to count the total rows again and then delete those rows from spreadsheet.
With ActiveSheet
lastRow = .Cells(.Rows.count, "A").End(xlUp).Row
End With
Range("A2").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$P$2691").AutoFilter Field:=3, Criteria1:= _
"=ABC", Operator:=xlOr, Criteria2:="=XYZ"
Rows("285:285").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
Regarding the question:
Instead of the value of 2691 for the last row, I want to pass lastRow variable..
The specific answer is to set the Range to filter using the lastRow variable that you set when you counted the rows in the range, e.g:
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Try the code below - each step is clearly commented.
Option Explicit
Sub Test()
Dim ws As Worksheet
Dim lastRow As Long
Dim rng As Range
'set sheet reference
Set ws = ActiveSheet
'turn off autofilter
ws.AutoFilterMode = False
'get last row
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'set range to filter
Set rng = ws.Range("A1:C" & lastRow)
'set filter
rng.AutoFilter Field:=3, Criteria1:="=ABC", Operator:=xlOr, Criteria2:="=XYZ"
'delete visible rows
rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
'show remaining rows by removing autofilter
ws.AutoFilterMode = False
End Sub

Copying certain columns VBA

I have a working VBA macro which copies from one spreadsheet 'AverageEarnings' to another 'Sheet1', under the condition that Column AO has the word 'UNGRADED' in it. The macro copies the entirety of these conditional rows to Sheet1. I am looking to copy columns B and C ('AverageEarnings') to columns A and B ('Sheet1'). How do I amend this.
Sub UngradedToSHEET1()
' UngradedToSHEET1 Macro
'
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long
Dim stringToFind As String
Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("AverageEarnings")
stringToFind = "UNGRADED"
With ws1
'Remove all filters from spreadsheet to prevent loss of information.
.AutoFilterMode = False
lRow = .Range("AO" & .Rows.Count).End(xlUp).Row 'Find a specific column.
With .Range("AO1:AO" & lRow) ' This is the row where GRADED or UNGRADED is specified.
.AutoFilter Field:=1, Criteria1:="=*" & stringToFind & "*" 'Filter specific information.
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'Remove spreadsheet filters again.
.AutoFilterMode = False
End With
Set ws2 = wb1.Worksheets("Sheet1")
With ws2
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then ' Find a blank row after A1.
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lRow = 1
End If
copyFrom.Copy .Rows(lRow)
End With
End Sub
This line copies the entire row:
Set copyFrom =
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
You will need to change EntireRow to just copy the columns you want, probably something like:
Set copyFrom =
.Offset(1, 0).SpecialCells(xlCellTypeVisible).Range(.Cells(1,2),.Cells(1,3))
Hope this helps, I can't check this right now.

VBA Copy and Paste in another Sheet from AutoFilter outputting one row

I have an AutoFilter that once it is applied it always outputs one row. I want to copy this one row and paste it on another Sheet.
I have considered:
xlCellTypeAllValidation but it throws out an error
xlCellTypeSameValidation there are many validation criteria an AutoFilter
xlCellTypeLastCell but it gives the location of the last cell in the filtered row
How can i do this?
Here is an excerpt from my code:
With ThisWorkbook.Sheets(k).Range("A1:AZ1")
.Value = .Value
.AutoFilter field:=1, Criteria1:=Rev_1
.AutoFilter field:=11, Criteria1:=Beginnings(k)
.AutoFilter field:=12, Criteria1:=End_Instnts(k)
For zz = 13 To last_Field
.AutoFilter field:=zz, Criteria1:=""
Next zz
.SpecialCells(xlCellTypeLastCell).Select
.Range.Select
ThisWorkbook.Sheets(k).AutoFilterMode = False
End With
I'd recommend testing to ensure something actually matched the criteria before you copy - something like:
With ThisWorkbook.Sheets(k).Range("A1").CurrentRegion.Resize(, 52)
.Value = .Value
.AutoFilter field:=1, Criteria1:=Rev_1
.AutoFilter field:=11, Criteria1:=Beginnings(k)
.AutoFilter field:=12, Criteria1:=End_Instnts(k)
For zz = 13 To last_Field
.AutoFilter field:=zz, Criteria1:=""
Next zz
' make sure there are results matching filter
If .Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
' offset and resize to avoid headers then copy
.Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("other sheet").Range("A1")
End If
ThisWorkbook.Sheets(k).AutoFilterMode = False
End With
You can select all filtered region and then copy it, it will copy visible rows only anyway. Or combine it with .SpeciallCells(xlCellTypeVisible)
Smthng like (after End With) (assuming data starts from Row 2)
Range("A2:AZ1").Copy Destination:=PasteRange
One approach is to use Special Cells targeting visible cells only. One really quick and painless variant is to just use offset.
See the following:
Sub CopyFilterResult()
Dim WS1 As Worksheet, WS2 As Worksheet
With ThisWorkbook
Set WS1 = .Sheets("Sheet1")
Set WS2 = .Sheets("Sheet2")
End With
'Apply your filters here.
WS1.UsedRange.Offset(1, 0).Copy WS2.Range("A1")
End Sub
Screenshots:
Source (with filter):
Result:
Something to keep as a an alternative.
Let us know if this helps.
EDIT:
This code is as per exchange in comments. Read the comments and modify it to suit your needs.
Sub CopyAfterFilterMk2()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim RngBeforeFilter As Range, RngAfterFilter As Range
Dim LCol As Long, LRow As Long
With ThisWorkbook
Set WS1 = .Sheets("Sheet1")
Set WS2 = .Sheets("Sheet2")
End With
With WS1
'Make sure no other filters are active.
.AutoFilterMode = False
'Get the correct boundaries.
LRow = .Range("A" & .Rows.Count).End(xlUp).Row
LCol = .Range("A1").End(xlToRight).Column
'Set the range to filter.
Set RngBeforeFilter = .Range(.Cells(1, 1), .Cells(LRow, LCol))
RngBeforeFilter.Rows(1).AutoFilter Field:=1, Criteria1:="o"
'Set the new range, but use visible cells only.
Set RngAfterFilter = .Range(.Cells(2, 1), .Cells(LRow, LCol)).SpecialCells(xlCellTypeVisible)
'Copy the visible cells from the new range.
RngAfterFilter.Copy WS2.Range("A1")
'Turn off the filter.
.AutoFilterMode = False
End With
End Sub
This code handles multiple rows post-filter as well.
Let us know if this helps.