Home	Excel	Access
| 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.

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 menu options Data | Filter | Advanced Filter 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.

• a single item (e.g. 'SMITH') underneath one of the fields
• more than one criteria item in a single row - applies an 'AND' rule (e.g. 'SMITH' and 'XN41')
• more than one criteria on different rows - applies an 'OR' rule (e.g. 'XN41' or '<1500')

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.

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

Would you like to learn more? Excel 2003 Power programming with VBA (with CD)

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.

Get this information as a document accompanied by Excel worksheets

Click here for details about obtaining this file