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

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,977
Office Version
  1. 365
Platform
  1. Windows
Perhaps duplicate values in the 2nd sheet ???
Are the values in Sheet2 not matching the values in Sheet1 somehow?

This now dumps results to a new sheet
Have a look and tell me why it is not giving the correct results

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
    With Sheets.Add
        Application.ScreenUpdating = False
         .Cells(1, 1).Resize(, 3) = Array("count", "value", "cell ref")
        For Each cel In rng2.Offset(1).Resize(rng2.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
            If List.Exists(cel.Value) Then
                c = c + 1
                .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3) = Array(c, cel, cel.Address(0, 0))
            End If
        Next
    End With
    MsgBox "There are " & c & " unique values "
End Sub
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest

kirankoushik

New Member
Joined
Feb 19, 2021
Messages
44
Office Version
  1. 2016
Platform
  1. Windows
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



Perhaps duplicate values in the 2nd sheet ???
Are the values in Sheet2 not matching the values in Sheet1 somehow?

This now dumps results to a new sheet
Have a look and tell me why it is not giving the correct results

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
    With Sheets.Add
        Application.ScreenUpdating = False
         .Cells(1, 1).Resize(, 3) = Array("count", "value", "cell ref")
        For Each cel In rng2.Offset(1).Resize(rng2.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
            If List.Exists(cel.Value) Then
                c = c + 1
                .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3) = Array(c, cel, cel.Address(0, 0))
            End If
        Next
    End With
    MsgBox "There are " & c & " unique values "
End Sub

👏🧠

ur right thanks.. it contained duplicate values in second sheet as a column that I am not using has different values in each row. Thus the code quoted at top is not able to delete those duplicate values in first column.,
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,977
Office Version
  1. 365
Platform
  1. Windows
Do you want the code modified to handle duplicate values?
 

kirankoushik

New Member
Joined
Feb 19, 2021
Messages
44
Office Version
  1. 2016
Platform
  1. Windows
Do you want the code modified to handle duplicate values?
yes please.. that would be a bonus!

Could I also ask your help if any improvement can be made in the section that is taking 5+ seconds ?
 

Yongle

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

ADVERTISEMENT

Try this
VBA Code:
Sub FilterAndMatch()
    Dim rng1 As Range, rng2 As Range, cel As Range, List As Object, List2 As Object, c As Long, itm As Variant
'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
'place sheet2 filtered values in scripting dictionary
    Set List2 = CreateObject("Scripting.Dictionary")
    For Each cel In rng2.Offset(1).Resize(rng2.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
        If Not List2.Exists(cel.Value) Then List2.Add cel.Value, Nothing
    Next cel
'count common elements
    For Each itm In List2
        If List.Exists(itm) Then c = c + 1
    Next itm
    MsgBox "There are " & c & " unique values "
End Sub
 

kirankoushik

New Member
Joined
Feb 19, 2021
Messages
44
Office Version
  1. 2016
Platform
  1. Windows
Try this
VBA Code:
Sub FilterAndMatch()
    Dim rng1 As Range, rng2 As Range, cel As Range, List As Object, List2 As Object, c As Long, itm As Variant
'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
'place sheet2 filtered values in scripting dictionary
    Set List2 = CreateObject("Scripting.Dictionary")
    For Each cel In rng2.Offset(1).Resize(rng2.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
        If Not List2.Exists(cel.Value) Then List2.Add cel.Value, Nothing
    Next cel
'count common elements
    For Each itm In List2
        If List.Exists(itm) Then c = c + 1
    Next itm
    MsgBox "There are " & c & " unique values "
End Sub
thank you this is working perfectly.,
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,977
Office Version
  1. 365
Platform
  1. Windows
Next week I will make the code run faster. Look again in 7 days
 

Watch MrExcel Video

Forum statistics

Threads
1,129,686
Messages
5,637,825
Members
416,984
Latest member
dee10

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