VBA: compare combinations of two cells

Nelson78

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

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
Sort by date Sort by votes
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
JackDanIce said:
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
Click to expand...

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
JackDanIce said:
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
Click to expand...

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
JackDanIce said:
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.
Click to expand...

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
JackDanIce said:
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
Click to expand...

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
You must log in or register to reply here.

Similar threads

ajjava
  • Question Question
Procedure to find MAX VALUE in a SPECIFIC pivot table value field, in the case of MULTIPLE pivot table value fields
Replies
0
Views
2K
ajjava
ajjava
J
  • Solved
VBA to compare rows in two different sheets, if match highlight cell
2
Replies
10
Views
1K
kevin9999
K
Z
  • Solved
Insert (paste) multiple rows below a user-selected cell
Replies
4
Views
693
zankzank
Z
S
  • Question Question
Excel VBA - Sort & Get Totals - Logic
Replies
4
Views
340
STARL0RD
S
C
  • Question Question
Replacing PowerPoint Input using Find and Replace Arrays from Excel through VBA
Replies
0
Views
2K
ckcs
C

Forum statistics

Threads
1,223,234
Messages
6,170,891
Members
452,366
Latest member
TePunaBloke

Share this page

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