CountIfs and VLookup across multiple sheets using VBA

kirankoushik

New Member
Joined
Feb 19, 2021
Messages
44
Office Version
  1. 2016
Platform
  1. Windows
Hello,

I am trying to extract total / summary data from a workbook using VBA. The datarange is to the tune of 15,000 rows .

I am not sure if it can be possibly done at all. Request your help in this regard.

I have 2 sheets with first column being same across both sheets but jumbled in order. What I am trying to achieve is :

1. I need to check if Col D value is "ki" and Col G value is "ko" resulting in 3 cases where both criteria match in sheet 1
2. For those 3 cases in Sheet 2, I need to check if Col C value is "FN" and Col I value is "LN"

So the final result of this exercise is to have output count of 1 (i.e. matching value of a24 in Col A.

Please look at the screenshots if my explanation is not clear.

Thanks in advance.
 

Attachments

  • S1.PNG
    S1.PNG
    52.5 KB · Views: 6
  • S2.PNG
    S2.PNG
    58.1 KB · Views: 8

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,977
Office Version
  1. 365
Platform
  1. Windows
Welcome to MrExcel

Are the values in column A unique within each sheet?
- ie each value appears ONCE only in column A

What should the output be?
- a simple list of matched items found in both sheets?
 
Last edited:

kirankoushik

New Member
Joined
Feb 19, 2021
Messages
44
Office Version
  1. 2016
Platform
  1. Windows
Welcome to MrExcel

Are the values in column A unique within each sheet?
- ie each value appears ONCE only in column A

What should the output be?
- a simple list of matched items found in both sheets?

Thank you Yongle

1. Yes the values in Col A is unique
2. Output I am looking for is only a count (not the value)
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,977
Office Version
  1. 365
Platform
  1. Windows
Try this
VBA Code:
Sub FilterAndMatch()
    Dim rng1 As Range, rng2 As Range, cel As Range, List As Object, c As Long
'filter sheet1
    Set rng1 = Sheets("Sheet1").Range("A1").CurrentRegion
    rng1.Cells(1, 1).AutoFilter
    rng1.AutoFilter Field:=7, Criteria1:="ko"
    rng1.AutoFilter Field:=4, Criteria1:="ki"
'filter sheet2
    Set rng2 = Sheets("Sheet2").Range("A1").CurrentRegion
    rng2.Cells(1, 1).AutoFilter
    rng2.AutoFilter Field:=9, Criteria1:="LN"
    rng2.AutoFilter Field:=3, Criteria1:="FN"
'place sheet1 filtered values in scripting dictionary
    Set List = CreateObject("Scripting.Dictionary")
    For Each cel In rng1.Offset(1).Resize(rng1.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
        If Not List.Exists(cel.Value) Then List.Add cel.Value, Nothing
    Next cel
'add to count if dictionary contains filtered values in Sheet2
    For Each cel In rng2.Offset(1).Resize(rng2.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
        If List.Exists(cel.Value) Then c = c + 1
    Next
    MsgBox "There are " & c & " unique values "
End Sub
 
Solution

kirankoushik

New Member
Joined
Feb 19, 2021
Messages
44
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

Try this
VBA Code:
Sub FilterAndMatch()
    Dim rng1 As Range, rng2 As Range, cel As Range, List As Object, c As Long
'filter sheet1
    Set rng1 = Sheets("Sheet1").Range("A1").CurrentRegion
    rng1.Cells(1, 1).AutoFilter
    rng1.AutoFilter Field:=7, Criteria1:="ko"
    rng1.AutoFilter Field:=4, Criteria1:="ki"
'filter sheet2
    Set rng2 = Sheets("Sheet2").Range("A1").CurrentRegion
    rng2.Cells(1, 1).AutoFilter
    rng2.AutoFilter Field:=9, Criteria1:="LN"
    rng2.AutoFilter Field:=3, Criteria1:="FN"
'place sheet1 filtered values in scripting dictionary
    Set List = CreateObject("Scripting.Dictionary")
    For Each cel In rng1.Offset(1).Resize(rng1.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
        If Not List.Exists(cel.Value) Then List.Add cel.Value, Nothing
    Next cel
'add to count if dictionary contains filtered values in Sheet2
    For Each cel In rng2.Offset(1).Resize(rng2.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
        If List.Exists(cel.Value) Then c = c + 1
    Next
    MsgBox "There are " & c & " unique values "
End Sub

Thank you very much for your time.. it is working perfectly..

ur a lifesaver... : )
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,977
Office Version
  1. 365
Platform
  1. Windows
(y) Glad the code does what you wanted
 

kirankoushik

New Member
Joined
Feb 19, 2021
Messages
44
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

(y) Glad the code does what you wanted
(y)

Am wondering if For loop is the one taking time for execution.

Could the same be achieved in a faster way ? without loop ?
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,977
Office Version
  1. 365
Platform
  1. Windows
How long is it taking?
How many records are there in both sheets AFTER filtering?
 

kirankoushik

New Member
Joined
Feb 19, 2021
Messages
44
Office Version
  1. 2016
Platform
  1. Windows
How long is it taking?
How many records are there in both sheets AFTER filtering?
it is having 2970+804=3774 records together

Sry, I just used a timer to calculate time taken, it appears that loop is not the one eating away my time.

The below code is taking a solid 5+ secs.

VBA Code:
    varFile = Application.GetOpenFilename()
    StartTime = Timer '/////////////////
    If varFile = False Then
        MsgBox "The user aborted"
        nofile = False
        Exit Sub
    End If
    
'Delete Old Export
  On Error Resume Next 'If worksheet is missing
    Application.DisplayAlerts = Bypass
    Worksheets("Sheet1a").Delete
    Worksheets("Sheet2b").Delete
    Worksheets("Sheet3c").Delete
    Worksheets("Sheet4d").Delete

'Export Insert

If Workbooks.Open(varFile).Sheets.Count = 11 _
And Sheets(1).Name = "Sheet1a" _
Then
    With Workbooks.Open(varFile)
        .Worksheets("Sheet1a").Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        .Worksheets("Sheet2b").Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        .Worksheets("Sheet3c").Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        .Worksheets("Sheet4d").Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        .Close False
        
        Worksheets("Sheet1a").Activate
    ActiveSheet.Range("$A$2:$CR" & ActiveSheet.UsedRange.Rows.Count).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5 _
        , 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, _
        33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 53, 61, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, _
        75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96), Header:= _
        xlYes
    
        Worksheets("Sheet2b").Activate
    ActiveSheet.Range("$A$2:$E" & ActiveSheet.UsedRange.Rows.Count).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:= _
        xlYes

        Worksheets("Sheet3c").Activate

    ActiveSheet.Range("$A$2:$AG" & ActiveSheet.UsedRange.Rows.Count).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5 _
        , 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, _
        33), Header:= _
        xlYes
        
        Worksheets("Sheet4d").Activate

    ActiveSheet.Range("$A$2:$J" & ActiveSheet.UsedRange.Rows.Count).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5 _
        , 6, 7, 8, 9, 10), Header:= _
        xlYes

    End With
    
SecondsElapsed = Round(Timer - StartTime, 2) '/////////////////
  MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
 

kirankoushik

New Member
Joined
Feb 19, 2021
Messages
44
Office Version
  1. 2016
Platform
  1. Windows
Update: The code is not working correctly

The test file it worked fine.

In actual data the output seems to be throwing an incorrect value.

Sheet 1 after applying 2 filters has 804 rows,
Sheet 2 after applying 1 filter has 2970 rows,

The output : MsgBox "There are " & c & " unique values " is showing the result as 1539.

The result should not exceed 804 in any case.
 

Watch MrExcel Video

Forum statistics

Threads
1,129,774
Messages
5,638,268
Members
417,019
Latest member
PKDP

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top