MeadInKent
| Database functions | Macros and buttons | Extracting words from text |

An Excel advanced filter and a macro to extract records from a list

If you have a list of records contained in a range of cells it is possible to extract all records that meet a specified set of criteria and place them elsewhere in your workbook. For example in a list of names and personal details you could find everyone who works for a particular organisation and has a birthday in June. This is a much smarter alternative to sorting, resorting, copying and pasting the data.

an advanced filter dialog box

If the filtering is an infrequent exercise it can be achieved using the Excel menu options but if the task is regularly required it may be worth writing a short macro program to simplify the process.

The option [Data] Sort and Filter | Advanced opens a dialog box (right) which enables you to copy particular records to another location within your workbook. The List range refers to your source data; the Criteria range to a range of cells containing the rules which determine the records to be selected; the Copy to range are the cells in which the extracted records are to be placed and must be on the same worksheet as the original data.

The criteria range works on the same basis as with Database functions like DSUM(). It is a range of cells headed by the field names against which you wish to set conditions. There are three types of conditions / criteria.

Wildcarding and greater than (>) or less than (<) operators can be used.

Advanced filters can be a simple way to extract a list of all of the unique values in a range - i.e. removing all duplicates. Simply enter the details into the Advanced Filter dialog box, leaving the criteria blank, adding a new cell at which to start copying the extracted values and finally selecting the 'Unique records only' tick box.

A macro can be used to automate the filtering process - identifying a List range, pre-programmed with the Criteria and the Copy to ranges. The results can be on a different worksheet than the original data.

- A B C D E
2 Payroll source data   LastRow 14
3 grade surname payroll_no period amount
4 XN41 White 20/3456 M01 2300
5 XN41 White 20/3456 M02 2300
6 XN41 White 20/3456 M03 2300
7 XN46 Last 20/4211 M01 2450
8 XN46 Last 20/4211 M02 2450
9 XN46 Last 20/4211 M03 2680
10 XC21 Hornsby 14/0321 M01 1645
11 XC21 Hornsby 14/0321 M02 1640
12 XC21 Hornsby 14/0321 M03 1655
13 XC21 Latham 15/7452 M02 1540
14 XC21 Latham 15/7452 M03 1540
- A B C D E F
1 CRITERIA      
2   grade surname payroll_no period amount
3 1 XN4     M01  
4 2   L   M02  
5 3          
6            
7 RESULTS      
8   grade surname payroll_no period amount
9   XN41 White 20/3456 M01 2300
10   XN46 Last 20/4211 M01 2450.00
11   XN46 Last 20/4211 M02 2450.00
12   XC21 Latham 15/7452 M02 1540.00

The criteria in the above example have been set to select records with any Grade starting with 'XN4' and also a Period of 'M01' plus any records with a Surname starting with 'L' and a period of 'M02'. Up to 3 sets of (OR) criteria can be entered in this example although you could modify the macro and worksheet to accept more or fewer rows. The following macro program has been linked to a button (labelled 'My Filter') placed on the worksheet.

Sub MyQuery()
Dim MaxResults As Integer, MyCol As Integer, ResultsRng As String
Dim MyRow As Integer, LastDataRow As Integer, DataRng As String
Dim CritRow As Integer, CritRng As String, RightCol As Integer
Dim TopRow As Integer, BottomRow As Integer, LeftCol As Integer


' the source data MUST be in a worksheet called 'Data'

' *** MODIFY AND SET YOUR OWN RANGES ON THE FOLLOWING DECLARATIONS ***

' cell Data!E2 contains the last row number of data [=COUNT(E4:E100)+3]

LastDataRow = Worksheets("data").Range("E2").Value

DataRng = "A3:E3" ' range of column headers for Data table
CritRng = "B2:F5" ' range of cells for Criteria table
ResultsRng = "B8:F8" ' range of headers for Results table
MaxResults = 1000 ' any value higher than the number of possible results

' **************** END OF DECLARATIONS *********************

' fix the data range to incorporate the last row


TopRow = Range(DataRng).Row
LeftCol = Range(DataRng).Column
RightCol = LeftCol + Range(DataRng).Columns.Count - 1
DataRng = Range(Cells(TopRow, LeftCol), Cells(LastDataRow, RightCol)).Address

' fix the results range to incorporate the last row

TopRow = Range(ResultsRng).Row
LeftCol = Range(ResultsRng).Column
RightCol = LeftCol + Range(ResultsRng).Columns.Count - 1
ResultsRng = Range(Cells(TopRow + 1, LeftCol), Cells(MaxResults, RightCol)).Address
Range(ResultsRng).ClearContents ' clear any previous results but not headers
ResultsRng = Range(Cells(TopRow, LeftCol), Cells(MaxResults, RightCol)).Address

' fix the criteria range and identify the last row containing any items

TopRow = Range(CritRng).Row
BottomRow = TopRow + Range(CritRng).Rows.Count - 1
LeftCol = Range(CritRng).Column
RightCol = LeftCol + Range(CritRng).Columns.Count - 1
CritRow = 0

For MyRow = TopRow + 1 To BottomRow
For MyCol = LeftCol To RightCol
If Cells(MyRow, MyCol).Value <> "" Then CritRow = MyRow
Next
Next

If CritRow = 0 Then
MsgBox "No Criteria detected", "MeadInKent"
Else
CritRng = Range(Cells(TopRow, LeftCol), Cells(CritRow, RightCol)).Address
Debug.Print "DataRng, CritRng, ResultsRng: ", DataRng, CritRng, ResultsRng

Worksheets("Data").Range(DataRng).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range(CritRng), CopyToRange:=Range(ResultsRng), _
Unique:=False
End If
Range("A5").Select
End Sub
A macro program to automate the Excel Advanced Filter. This can be copied and pasted into your own Excel module. Note that in my workbook there are two worksheets - 'Data' and 'Results'. The button is placed on the Results worksheet.

save this free reference page with examples of 8 Excel functions

Click to download this PDF document


excel Get this information as a document
accompanied by Excel worksheets
Document is in PDF format Click here for details about obtaining this
file. It has been rewritten for Excel 2010.

file: xlfilter.htm Page last updated Feb14 © meadinkent.co.uk 2016 CMIDX S2 P4 Y