vba code for apply multiple filters based on multiple criteria

Question

I am looking for VBA code for below problem. there are three sheets in excel 

1.Raw data (see in attached excel workbook) 

2.Criteria 

3.Result 

Raw data sheet has 5 columns ( country, state, district, name, age ) , 80 thousand rows 

Criteria sheet has 3 columns (country, state, district) , 20 rows. unique values 

My expectations form the code : 

I. i need to apply filters in raw data sheet with visible values of criteria sheet , 

II. if values are not found in raw data sheet values of should highlight in another color in criteria sheet. 

III.what are the values found in raw data sheet should copy and paste in results sheet. 

I have following code but not satisfying second expectation :if values are not found in raw data sheet , values should highlight in another color in criteria sheet. 

You can access sample data here.

https://drive.google.com/file/d/0B6fyfvaAj2ANemgwUjFlQllVTkE/view?usp=sharing

Please review my code and please do needful. 

My Code: 

Sub DoIt() 

Dim rs As Worksheet, Cs As Worksheet, UltSh As Worksheet 

Dim Frng As Range, Crng As Range 

Dim Lstrws As Long 

Dim Rws As Long, rng As Range, c As Range 

Set rs = Sheets("Raw Data") 

Set Cs = Sheets("Criteria") 

Set UltSh = Sheets("Result") 

With Cs 

Rws = .Cells(.Rows.Count, "A").End(xlUp).Row 

Set rng = .Range(.Cells(2, "A"), .Cells(Rws, "A")) 

End With 

For Each c In rng.Cells 

With rs 

Lstrws = .Cells(.Rows.Count, "A").End(xlUp).Row 

Set Frng = .Range("A1:E" & Lstrws) 

Frng.AutoFilter Field:=1, Criteria1:=c 

Frng.AutoFilter Field:=2, Criteria1:=c.Offset(, 1) 

Frng.AutoFilter Field:=3, Criteria1:=c.Offset(, 2) 

Set Crng = Frng.Offset(1) 

Crng.Copy UltSh.Cells(UltSh.Rows.Count, "A").End(xlUp).Offset(1) 

.AutoFilterMode = 0 

End With 

Next c 

End Sub

Kindly help me.

Regards

Mani

Answer 1

Hi Tom Ogilvy,

You made my day, Thanks a billion.

Regards

Mani

Answer 2

bollamani,

This worked for me:

Sub DoIt()

Dim rs As Worksheet, Cs As Worksheet, UltSh As Worksheet

Dim Frng As Range, Crng As Range, Crng1 As Range

Dim Lstrws As Long

Dim Rws As Long, rng As Range, c As Range

Set rs = Sheets("Raw Data")

Set Cs = Sheets("Criteria")

Set UltSh = Sheets("Result")

With Cs

Rws = .Cells(.Rows.Count, "A").End(xlUp).Row

Set rng = .Range(.Cells(2, "A"), .Cells(Rws, "A"))

End With

For Each c In rng.Cells

With rs

Lstrws = .Cells(.Rows.Count, "A").End(xlUp).Row

Set Frng = .Range("A1:E" & Lstrws)

Frng.AutoFilter Field:=1, Criteria1:=c

Frng.AutoFilter Field:=2, Criteria1:=c.Offset(, 1)

Frng.AutoFilter Field:=3, Criteria1:=c.Offset(, 2)

Set Crng = Frng.Offset(1)

Set Crng1 = Crng.Resize(, 1)

If Application.Subtotal(3, Crng1) > 0 Then

 Crng.Copy UltSh.Cells(UltSh.Rows.Count, "A").End(xlUp).Offset(1)

Else

 c.Resize(1, 3).Interior.ColorIndex = 3

End If

.AutoFilterMode = 0

End With

Next c

End Sub

--

Regards,

Tom Ogilvy