in vba - Count occurrences of elements of a column compared to elements of another column - with dictionary

[harzer]

Hi there,
Despite my efforts to solve my problem, unfortunately I can't.
I put at your disposal my file with the code that I have already put in place to solve the part that I know how to do, I hope that this part of the code already done can be kept to avoid you writing all the code as a whole.
Explanations:
I have a sheet called "B_D" which contains my data, the data I'm working with currently is mostly in column "K" and "N".
The purpose of the code to be implemented is to do the following work:
• Retrieve all the data from column "K" (from the 3rd line) and those from column "N" (from the 3rd line too) to place them one below the other in the column "BA " from the 2nd line. (The code for this step is existing and working).
• Create a list without duplicates from columns "K" and "N" and put this list in column "BB" of sheet "B_D" and also in column "A" of sheet "Test" on line 2. (The code for this step is existing and working).
Just for your information, my data in all three columns is large, mainly the "BA" column which contains 21200 rows, I reduced the column size for my tests. I think the use of the dictionary is necessary to speed up the processing.
• This is where I can't solve my problem!!!!!!
This is what I would like to do:
Compare each element of column "A" of the sheet "Test" to compare it with all the elements of column "K", if the element is repeated in column "K", we count so(counter = counter + 1)
Example: The first element (HWA96-046/2019 M) located in the 2nd line of column "A" of the "Test" sheet, is repeated only once in column "K", so we will indicate this number (1) in column "B" on the same line as the element (HWA96-046/2019 M) of column "B" of the sheet "Test" (thus cell B2).
When the comparison and counting are finished, place all the numbers found in column "B" on their respective lines.
Then I do the same with all the items in column "A" of the "Test" sheet to compare with the items in column "N" and place all the numbers found in column "C" of the sheet " Test"
When this work is finished, I start the same thing again but this time I compare the elements of column "A" of the sheet "Test", with those of the column "BA" of the sheet "B_D", the numbers found will be placed in column "D" of the "Test" sheet.
Thanks in advance for your suggestions.
I remain at your disposal for any additional information.
Cheers.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Here are the 3 codes that I have set up for the 3 buttons of the "B_D" sheet.

Sub Effacer_Cols()
'supprimer anciennes données
Dim DernLigne As Long
DernLigne = Sheets("B_D").Range("BA" & Rows.Count).End(xlUp).Row
Sheets("B_D").Range("BA2:BE" & DernLigne).ClearContents
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Copier_Colonne_K_Et_N_En_Colonne_BA()
Application.ScreenUpdating = False
'copier colonne "K" et "N" en colonne "BA" en mettant les résultats les uns en dessous des autres
'La copie doit commencer absolument à partir de la ligne 3
With Sheets("B_D")
Range("K3:K" & Range("K" & Rows.Count).End(xlUp).Row).Copy .Range("BA2")
Range("N3:N" & Range("N" & Rows.Count).End(xlUp).Row).Copy .Range("BA" & Rows.Count).End(xlUp).Offset(1, 0)
End With
' Fin du code copier colonne "K" et "N" en colonne "BA" en mettant les résultats les uns en dessous des autres
Application.ScreenUpdating = True
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Liste_BB_sans_Doublon()
Dim c As Range, dico
Dim tabloA, tabloB, tabloAuB(), tabloR(), i, k, t, flag

tabloA = Range("K3:K" & Range("K" & Rows.Count).End(xlUp).Row)
tabloB = Range("N3:N" & Range("N" & Rows.Count).End(xlUp).Row)
ReDim tabloAuB(UBound(tabloA, 1) + UBound(tabloB, 1), 1)
For i = 1 To UBound(tabloA, 1)
tabloAuB(i - 1, 0) = tabloA(i, 1)
Next i

For i = i To UBound(tabloAuB, 1)
tabloAuB(i - 1, 0) = tabloB(i - UBound(tabloA, 1), 1)
Next i

k = 0
For i = 0 To UBound(tabloAuB, 1) - 1
ReDim Preserve tabloR(1, k + 1)
flag = 0
For t = 0 To UBound(tabloR, 2) - 1
If tabloR(0, t) = tabloAuB(i, 0) Then
flag = 1
End If
Next t
If flag = 0 Then
tabloR(0, k) = tabloAuB(i, 0)
k = k + 1
End If
Next i
Sheets("Test").Range("A2").Resize(UBound(tabloR, 2), 1) = Application.Transpose(tabloR)
Sheets("Test").Range("A2").Resize(UBound(tabloR, 2), 1).NumberFormat = "0"
Sheets("B_D").Range("BB2").Resize(UBound(tabloR, 2), 1) = Application.Transpose(tabloR)
Sheets("B_D").Range("BB2").Resize(UBound(tabloR, 2), 1).NumberFormat = "0"
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''

 

[Alex Blakenburg]

Give this a try:
Note: I am not sure why you are formatting Column BB of B_D and Column A of Test as Number "0" but I have left it the way you had it.

Sub Liste_BB_sans_Doublon()
    Dim tabloA, tabloB, tabloR()
    Dim i As Long, idxR As Long
    Dim dictCodes As Object, dictKey As String
   
    tabloA = Range("K3:K" & Range("K" & Rows.Count).End(xlUp).Row).Value
    tabloB = Range("N3:N" & Range("N" & Rows.Count).End(xlUp).Row).Value

    ReDim tabloR(1 To (UBound(tabloA) + UBound(tabloB)), 1 To 4)

    Set dictCodes = CreateObject("Scripting.dictionary")
   
    ' Load details range into Dictionary & count
    ' 1st table
    For i = 1 To UBound(tabloA)
        dictKey = tabloA(i, 1)
        If Not dictCodes.exists(dictKey) Then
            idxR = idxR + 1
            dictCodes(dictKey) = idxR
            tabloR(dictCodes(dictKey), 1) = dictKey
        End If
        tabloR(dictCodes(dictKey), 2) = tabloR(dictCodes(dictKey), 2) + 1    ' Total tabloA
        tabloR(dictCodes(dictKey), 4) = tabloR(dictCodes(dictKey), 4) + 1    ' Combined Total
    Next i
   
    ' 2nd table
    For i = 1 To UBound(tabloB)
        dictKey = tabloB(i, 1)
        If Not dictCodes.exists(dictKey) Then
            idxR = idxR + 1
            dictCodes(dictKey) = idxR
            tabloR(dictCodes(dictKey), 1) = dictKey
        End If
        tabloR(dictCodes(dictKey), 3) = tabloR(dictCodes(dictKey), 3) + 1    ' Total tabloB
        tabloR(dictCodes(dictKey), 4) = tabloR(dictCodes(dictKey), 4) + 1    ' Combined Total
    Next i
   
    ' Output results
    Sheets("Test").Range("A2").Resize(idxR, 4) = tabloR
    Sheets("Test").Range("A2").Resize(idxR, 4).NumberFormat = "0"
    Sheets("B_D").Range("BB2").Resize(idxR, 1) = Application.Index(tabloR, 0, 1)
    Sheets("B_D").Range("BB2").Resize(idxR, 1).NumberFormat = "0"
End Sub

 

[harzer]

Hello Alex Blakenburg and the forum, Thank you for your proposal and a big THANK YOU. Following your information, I deleted the 2 lines for formatting column "BB" of "B_D" and column "A" of "test" since the result is correct, so no interest in keeping that. Thank you for the proposed code, it works perfectly and meets my expectations. Cheers.

 

[Alex Blakenburg]

You're welcome. Thanks for letting me know and glad I could help.