VBA: compare combinations of two cells

Nelson78

Well-known Member
Joined
Sep 11, 2017
Messages
526
Office Version
  1. 2007
Hello everybody.

I have the following job.

In sheet2 there are a variable number of association column A/B (in this case 5).

The goal is matching these 5 associations with the associations already present in sheet1:
- if already present, do nothing
- if not present, insert a row below the related item and report the unprecedented association.

The outcome has to be as you can see in the image

https://imgur.com/a/1MZVZEY
 

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.
This assumes headers are in row 1 of Sheet1 and Sheet2, try:
Code:
Sub M1()
    
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    Dim arr()   As Variant
    Dim x       As Long
    Dim rng     As Range
    
    Application.ScreenUpdating = False
    
    With sheets("Sheet1")
        arr = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 2).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            dic(arr(x, 1) & arr(x, 2)) = x
        Next x
        
        arr = sheets("Sheet2").Cells(2, 1).Resize(sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row - 1, 2).Value
        .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr, 1), 2).Value = arr
                
        With .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 2)
            .RemoveDuplicates Columns:=Array(1, 2), header:=xlYes
            .Sort key1:=.Cells(1, 1), order1:=xlAscending, header:=xlYes
        End With
        
        arr = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 2).Value
        
        For x = LBound(arr, 1) To UBound(arr, 1)
            If Not dic.exists(arr(x, 1) & arr(x, 2)) Then
                On Error Resume Next
                If rng Is Nothing Then
                    Set rng = .Cells(x, 1).Resize(, 2)
                Else
                    Set rng = Union(rng, .Cells(x, 1).Resize(, 2))
                End If
                On Error GoTo 0
            End If
        Next x
           
    End With
    
    If Not rng Is Nothing Then
        With rng
            .Font.Bold = True
            .Interior.Color = vbYellow
        End With
        Set rng = Nothing
    End If
    
    Application.ScreenUpdating = True
    
    Erase arr: Set dic = Nothing
    
End Sub
 
Last edited:
Upvote 0
Another option:- Results in sheet1 starting "A2"

Code:
[COLOR=navy]Sub[/COLOR] MG28Sep29
[COLOR=navy]Dim[/COLOR] Dn          [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Rng1        [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Rng2        [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Dic         [COLOR=navy]As[/COLOR] Object
[COLOR=navy]Dim[/COLOR] n           [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] Ray         [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]With[/COLOR] Sheets("Sheet1")
    [COLOR=navy]Set[/COLOR] Rng1 = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
[COLOR=navy]End[/COLOR] With
 [COLOR=navy]With[/COLOR] Sheets("Sheet2")
    [COLOR=navy]Set[/COLOR] Rng2 = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
[COLOR=navy]End[/COLOR] With
  [COLOR=navy]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
        Ray = Array(Rng1, Rng2)
   
   [COLOR=navy]For[/COLOR] n = 0 To 1
        [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Ray(n)
            [COLOR=navy]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR=navy]Then[/COLOR]
                [COLOR=navy]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
            [COLOR=navy]End[/COLOR] If
        
        [COLOR=navy]If[/COLOR] Not Dic(Dn.Value).exists(Dn.Offset(, 1).Value) [COLOR=navy]Then[/COLOR]
                Dic(Dn.Value).Add (Dn.Offset(, 1).Value), ""
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Dn
[COLOR=navy]Next[/COLOR] n
   
   [COLOR=navy]Dim[/COLOR] k     [COLOR=navy]As[/COLOR] Variant
   [COLOR=navy]Dim[/COLOR] p    [COLOR=navy]As[/COLOR] Variant
   [COLOR=navy]Dim[/COLOR] c    [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
c = 1
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] k [COLOR=navy]In[/COLOR] Dic.Keys
          For Each p In Dic(k) 
                   c = c + 1
                 Cells(c, "A") = k
                 Cells(c, "B") = p
          [COLOR=navy]Next[/COLOR] p
    [COLOR=navy]Next[/COLOR] k
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0
This assumes headers are in row 1 of Sheet1 and Sheet2, try:
Code:
Sub M1()
    
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    Dim arr()   As Variant
    Dim x       As Long
    Dim rng     As Range
    
    Application.ScreenUpdating = False
    
    With sheets("Sheet1")
        arr = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 2).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            dic(arr(x, 1) & arr(x, 2)) = x
        Next x
        
        arr = sheets("Sheet2").Cells(2, 1).Resize(sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row - 1, 2).Value
        .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr, 1), 2).Value = arr
                
        With .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 2)
            .RemoveDuplicates Columns:=Array(1, 2), header:=xlYes
            .Sort key1:=.Cells(1, 1), order1:=xlAscending, header:=xlYes
        End With
        
        arr = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 2).Value
        
        For x = LBound(arr, 1) To UBound(arr, 1)
            If Not dic.exists(arr(x, 1) & arr(x, 2)) Then
                On Error Resume Next
                If rng Is Nothing Then
                    Set rng = .Cells(x, 1).Resize(, 2)
                Else
                    Set rng = Union(rng, .Cells(x, 1).Resize(, 2))
                End If
                On Error GoTo 0
            End If
        Next x
           
    End With
    
    If Not rng Is Nothing Then
        With rng
            .Font.Bold = True
            .Interior.Color = vbYellow
        End With
        Set rng = Nothing
    End If
    
    Application.ScreenUpdating = True
    
    Erase arr: Set dic = Nothing
    
End Sub

It works fine, but there is one more variable to consider (that I omitted - but I shoudn't - for a better understanding).

Inserting a row in sheet1 - as done so far in a manual way - preserves the correct position of data in columns from C to infinity.

Example: I have a data in cell R17. Inserting, let me suppose, a row just below row number 7, than the data in R17 has to be moved in R18 (but in general, the entire row 17 has to became row 18, and more in general all the rows from 8 to infinity has to be shifted one row below).

I hope to have been clear enough.
 
Upvote 0
Try:
Code:
Sub M1()
    
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    Dim arr()   As Variant
    Dim x       As Long
    Dim rng     As Range
    
    Application.ScreenUpdating = False
    
    With sheets("Sheet1")
        arr = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 2).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            dic(arr(x, 1) & arr(x, 2)) = x
        Next x
        
        arr = sheets("Sheet2").Cells(2, 1).Resize(sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row - 1, 2).Value
        x = 2
        
        Do Until Len(Cells(x, 1).Value) = 0
            If Not dic.exists(arr(x - 1, 1) & arr(x - 1, 2)) Then
                .Cells(x, 1).EntireRow.Insert
                With .Cells(x, 1).Resize(, 2)
                    .Value = Array(arr(x - 1, 1), arr(x - 1, 2))
                    .Font.Bold = True
                    .Interior.Color = vbYellow
                End With
            End If
            x = x + 1
        Loop
    End With
    
    
    Application.ScreenUpdating = True
    
    Erase arr: Set dic = Nothing
    
End Sub
 
Upvote 0
Try:
Code:
Sub M1()
    
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    Dim arr()   As Variant
    Dim x       As Long
    Dim rng     As Range
    
    Application.ScreenUpdating = False
    
    With sheets("Sheet1")
        arr = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 2).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            dic(arr(x, 1) & arr(x, 2)) = x
        Next x
        
        arr = sheets("Sheet2").Cells(2, 1).Resize(sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row - 1, 2).Value
        x = 2
        
        Do Until Len(Cells(x, 1).Value) = 0
            If Not dic.exists(arr(x - 1, 1) & arr(x - 1, 2)) Then
                .Cells(x, 1).EntireRow.Insert
                With .Cells(x, 1).Resize(, 2)
                    .Value = Array(arr(x - 1, 1), arr(x - 1, 2))
                    .Font.Bold = True
                    .Interior.Color = vbYellow
                End With
            End If
            x = x + 1
        Loop
    End With
    
    
    Application.ScreenUpdating = True
    
    Erase arr: Set dic = Nothing
    
End Sub

Something seems wrong on the last elaboration (Run time error 9: subscript out of range on the yellow line)

May be because of my attempt of tinkering?


https://imgur.com/a/Lb0wgc0
 
Last edited:
Upvote 0
Based on your first image, my code produces output as per Post Sheet1 Elaboration.

You haven't shared any "tickering" so unable to comment why that line is erroring.
 
Upvote 0
Based on your first image, my code produces output as per Post Sheet1 Elaboration.

You haven't shared any "tickering" so unable to comment why that line is erroring.

The only differences should be: columns involved in sheet2 AJ (36) e AK (37) rather than A (1) e B (2).
 
Upvote 0
Try:
Code:
Sub M1()
    
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    Dim arr()   As Variant
    Dim x       As Long
    Dim rng     As Range
    
    Application.ScreenUpdating = False
    
    With sheets("Sheet1")
        arr = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 2).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            dic(arr(x, 1) & arr(x, 2)) = x
        Next x
        
        arr = sheets("Sheet2").Cells(2, 36).Resize(sheets("Sheet2").Cells(Rows.Count, 36).End(xlUp).Row - 1, 2).Value
        x = 2
        
        Do Until Len(.Cells(x, 1).Value) = 0 Or x - 1 > UBound(arr, 1)
            If Not dic.exists(arr(x - 1, 1) & arr(x - 1, 2)) Then
                .Cells(x, 1).EntireRow.Insert
                With .Cells(x, 1).Resize(, 2)
                    .Value = Array(arr(x - 1, 1), arr(x - 1, 2))
                    .Font.Bold = True
                    .Interior.Color = vbYellow
                End With
            End If
            x = x + 1
        Loop
    End With
    
    
    Application.ScreenUpdating = True
    
    Erase arr: Set dic = Nothing
    
End Sub
 
Upvote 0
Try:
Code:
Sub M1()
    
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    Dim arr()   As Variant
    Dim x       As Long
    Dim rng     As Range
    
    Application.ScreenUpdating = False
    
    With sheets("Sheet1")
        arr = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 2).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            dic(arr(x, 1) & arr(x, 2)) = x
        Next x
        
        arr = sheets("Sheet2").Cells(2, 36).Resize(sheets("Sheet2").Cells(Rows.Count, 36).End(xlUp).Row - 1, 2).Value
        x = 2
        
        Do Until Len(.Cells(x, 1).Value) = 0 Or x - 1 > UBound(arr, 1)
            If Not dic.exists(arr(x - 1, 1) & arr(x - 1, 2)) Then
                .Cells(x, 1).EntireRow.Insert
                With .Cells(x, 1).Resize(, 2)
                    .Value = Array(arr(x - 1, 1), arr(x - 1, 2))
                    .Font.Bold = True
                    .Interior.Color = vbYellow
                End With
            End If
            x = x + 1
        Loop
    End With
    
    
    Application.ScreenUpdating = True
    
    Erase arr: Set dic = Nothing
    
End Sub

It works very well.

The problem is that in real life, as usual happens, we have to deal with something unexpected.

In this case, some of the 76 associations are not univocal: i need to report on the receiving sheet just one of them, to avoid duplicates.

https://imgur.com/s6yT0Xg
 
Upvote 0

Forum statistics

Threads
1,223,911
Messages
6,175,325
Members
452,635
Latest member
laura12345

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
Back
Top