CountIfs and VLookup across multiple sheets using VBA

[kirankoushik]

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.

 

[Yongle]

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

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

 

[kirankoushik]

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.

    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

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]

Do you want the code modified to handle duplicate values?

 

[kirankoushik]

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]

Try this

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]

Try this

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]

Next week I will make the code run faster. Look again in 7 days

 

[kirankoushik]

Next week I will make the code run faster. Look again in 7 days

? thanks a ton., will do.,