Macro to extract records from a list

Hi,

Can anyone tell me why I can't run this macro? Please tell me what the error is. Thanks

The problem occurs when trying to AutoFilter. I'm not sure what it is you're trying to do with the AutoFilter, but if you're trying to make a copy of the data and drop it into a different WorkSheet this is not allowed by Excel. You can first drop it in the same Worksheet then do a cut/copy and paste into a different worksheet.

Hey,

I am not too sure but I did find this on the website. http://www.meadinkent.co.uk/xlfilter.htm

It says,
"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."

Actually, this is correct. I didn't realize this could be done, but I see how now. I believe you have to have the worksheet you are copying TO active in order to do this though. Also, if you are copying the data from a different worksheet make sure the autofilter is aware of this (i.e. range("A1:E5") is not the same thing as sheets("Sheet1").range("A1:E5") when the activesheet is "Sheet2").
So, run the macro with "Data" sheet active, then add this line:

Worksheets("Results").Activate

right before the autofilter. Also, you will have to make sure you are pasting to a completely blank area. So even the headers: grade, surname, etc. cannot exist where the autofilter is to be copying to.

hmm., do you think you can change it in the current file that I sent you. I'm not good with VB so i will need an example file to see. Thanks

See attached. Here is the code:

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
    
    'ADDED===================================
    'This activates the worksheet "Data"
    ThisWorkbook.Worksheets("Data").Activate
    '========================================
    
    ' 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
        
        'ADDED========================================
        'This activates the worksheet "Results"
        ThisWorkbook.Worksheets("Results").Activate
        
        'This clears everything in "B8:F1000" in sheet "Results"
        ActiveSheet.Range(ResultsRng).ClearContents
        '=============================================
        
        Worksheets("Data").Range(DataRng).AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range(CritRng), CopyToRange:=Range(ResultsRng), _
        Unique:=False
    End If
    Range("A5").Select
End Sub