Help with Filtering Multiple Criteria using VBA

[JimLes]

I have made an ugly attempt at filtering data based on 3 criteria. The goal is to filter a dataset and copy the filtered data into separate worksheets based on a unique division. The criteria for the filter is based on Division, Status not equal to "Comp", and a date input by the user.

The code below gets me the first two criteria by using a combination of autofilter and advanced filter, but I am unable to factor in the date input by the user. I have thought about an input box or using criteria in a particular cell but unsure how to add it.

Any help on adding the date parameter or cleaning up the code below so that it runs faster would be appreciated. I am not sure the autofilter on the first part was the best choice.


Sub DivisionFilter()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Data2")
Set rng = Range("Database")

'Autofilter data and copy to Worksheet Data2
Worksheets("Data2").Visible = True
Sheets("Data").Select
Selection.Autofilter
Selection.Autofilter Field:=20, Criteria1:="<>COMP", Operator:=xlAnd
Cells.Select
Range("K1").Activate
Selection.Copy
Sheets("Data2").Select
Cells.Select
ActiveSheet.Paste
Sheets("Data").Select
Selection.Autofilter

'extract a list of Divisions
Sheets("Data2").Select
ws1.Columns("J:J").Copy _
Destination:=Range("AZ1")
ws1.Columns("AZ:AZ").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("AX1"), Unique:=True
r = Cells(Rows.Count, "AX").End(xlUp).Row

'set up Criteria Area
Range("AZ1").Value = Range("J1").Value

For Each c In Range("AX2:AX" & r)
'add the rep name to the criteria area
ws1.Range("AZ2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Data2").Range("AZ1:AZ2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Data2").Range("AZ1:AZ2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If
Next
Worksheets("Data2").Visible = xlVeryHidden
Sheets("Summary").Select
MsgBox "Employees not completed have been filtered"
End Sub

 

[SkipVought]

Hi,

Please post VBA questions in Forum707.

HOWEVER, this does not need to be solved using VBA. You can ues MS QUERY, with a multitude of criteria.

faq68-5829.

Skip,

_{Have you heard that the roundest knight at King Arthur's round table was...
Sir Cumference!}

 

[JimLes]

Thanks! I will try it.