Compare 2 Lists to Generate List of Updates

[RNELSO2]

Hello Gurus,

Working in Excel 2007.
I'm attempting to compare 2 lists located on separate sheets of the same workbook. The comparison should be based on columns A B & C on both sheets with one twist, from this comparison I would like to generate a new list, to be located on a third sheet, of items that are matching except for the Version code (Column D). However, I only want to see results for lines where the version code is later in the alphabet than the similar item(s) in List 2. For example....

Sheet 1 List 1

Year	Model ID	Code	Version
2018	1201	2T	C
2018	1201	3P	A
2018	1201	3P	B
2018	1201	3Z	A
2018	1201	63	A

<tbody>
</tbody>

Sheet 2 List 2

Year	Model ID	Code	Version
2018	1201	GY	A
2018	1201	H6	A
2018	1201	2T	A
2018	1201	2T	B
2018	1201	H9	A
2018	1201	63	B
2018	1201	H4	A

<tbody>
</tbody>

The only item I expect to see on sheet3 would be the first row (2018 1201 2T C) from list 1. This is because it is the only code where the first 3 columns have a match but the Version on list 1 is later in the alphabet than the latest on list 2 (C vs A & B). The items in red do not qualify since List 1 has a version code that is earlier in the alphabet than the same item on list 2.

The version code will always be alphabetical. There can be a variable number of matches as shown in the example above.

Also, my lists are not formatted the same so I have some preliminary code to "clean" them up a bit. It would be preferable to include this in any solution.

Sub format()
Dim lastrow1 As Long
Dim lastrow2 As Long


    lastrow1 = Sheets("Sheet1").Range("A" & Rows.count).End(xlUp).Row
    lastrow2 = Sheets("Sheet2").Range("A" & Rows.count).End(xlUp).Row
    
Sheets("Sheet2").Select
    Columns("E:E").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("D2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.TextToColumns Destination:=Range("D2"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(2, 1), Array(4, 1)), TrailingMinusNumbers:= _
        True
    Columns("F:F").Select
    Selection.Delete Shift:=xlToLeft
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
    Range("D1") = "Version"


End Sub

Thank you in advance for your help.

 

[MickG]

Try this for results on sheet3.
NB:- I'll let you add your own code as required.

[COLOR="Navy"]Sub[/COLOR] MG17Apr27
[COLOR="Navy"]Dim[/COLOR] Rng1 [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng2 [COLOR="Navy"]As[/COLOR] Range, Col1 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Col2 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, Ray [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[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
Ray = Array(Rng1, Rng2)
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] ac = 0 To 1
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Ray(ac)
         Col1 = 0: Col2 = 0
         [COLOR="Navy"]If[/COLOR] ac = 0 [COLOR="Navy"]Then[/COLOR]
             Col1 = Asc(Dn.Offset(, 3).Value)
         [COLOR="Navy"]Else[/COLOR]
            Col2 = Asc(Dn.Offset(, 3).Value)
         [COLOR="Navy"]End[/COLOR] If
        Txt = Dn.Value & "," & Dn.Offset(, 1).Value & "," & Dn.Offset(, 2).Value
        [COLOR="Navy"]If[/COLOR] Not .Exists(Txt) [COLOR="Navy"]Then[/COLOR]
            .Add Txt, Array(Col1, Col2)
        [COLOR="Navy"]Else[/COLOR]
            Q = .Item(Txt)
               [COLOR="Navy"]If[/COLOR] ac = 0 [COLOR="Navy"]Then[/COLOR]
                     [COLOR="Navy"]If[/COLOR] Col1 > Q(0) [COLOR="Navy"]Then[/COLOR] Q(0) = Col1
               [COLOR="Navy"]ElseIf[/COLOR] ac = 1 [COLOR="Navy"]Then[/COLOR]
                    [COLOR="Navy"]If[/COLOR] Col2 > Q(1) [COLOR="Navy"]Then[/COLOR] Q(1) = Col2
              [COLOR="Navy"]End[/COLOR] If
          .Item(Txt) = Q
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]Next[/COLOR] ac
c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
   [COLOR="Navy"]If[/COLOR] .Item(K)(0) > 0 And .Item(K)(1) > 0 [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]If[/COLOR] .Item(K)(0) > .Item(K)(1) [COLOR="Navy"]Then[/COLOR]
        c = c + 1
       Sheets("Sheet3").Range("A1").Resize(, 4).Value = Array("Year", "Model ID", "Code", "Version")
       Sheets("Sheet3").Cells(c, 1).Resize(, 3).Value = Split(K, ",")
       Sheets("Sheet3").Cells(c, 4) = Chr(.Item(K)(0))
    [COLOR="Navy"]End[/COLOR] If
 [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[RNELSO2]

Wow, thanks Mick. Works like a charm! And as an added plus, it takes a couple steps out of the cleanup that needs to be done.

Quick follow up question. (Famous last words)
I have been using the code below (pardon the messy look) to almost accomplish what you have brilliantly done here. At the end of the code it is copying the entire row of data from sheet1 into the new sheet and then running a comparison to the previous version values on sheet2.

So starting in row2 on sheet3 we want to compare column 10 to column 7 on sheet2
Column 11 on sheet3 to column 8 on sheet2
Column 12 on sheet3 to column 9 on sheet2

Match = Green cell
Difference = Red cell

Is that possible to add to the code you have provided?

Option Base 1
Sub CopyDupesToNewSheet()


Cleanup


'To copy rows from "FIA Export" to a new sheet _
'when there are dupes in "FIA Export", Column D of values in "DV Export", column D


'This module must have an Option Base 1 declaration before any subs


'Variables
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim newSheet As Worksheet
Dim var1Array
Dim var2Array
Dim i As Long
Dim j As Long
Dim x As Long
Dim blnMatch As Boolean
Dim LRow As Long


'References
Set wb1 = ActiveWorkbook
Set wb2 = ActiveWorkbook
Set ws1 = wb1.Sheets("FIA Export")
Set ws2 = wb2.Sheets("DV Export")
Set ws3 = wb1.Sheets("Results")


Application.ScreenUpdating = False


'-------------------------------
'create array - Rows 1 to Last Row, column D
'Range includes headers
With ws1
    LRow = .Cells(Rows.count, "D").End(xlUp).Row
    var1Array = .Range(.Cells(1, "D"), .Cells(LRow, "D")).Value
End With


'create array - Rows 1 to Last Row, column D
'Range includes headers
With ws2
    LRow = .Cells(Rows.count, "D").End(xlUp).Row
    var2Array = .Range(.Cells(1, "D"), .Cells(LRow, "D")).Value
End With


With ws3
    LRow = .Cells(Rows.count, "A").End(xlUp).Row
End With
'-
For i = 1 To UBound(var2Array, 1)
      
    'Test for Matches
    If (i = UBound(var2Array, 1)) Then
    
        j = 1
        blnMatch = False
        Do While j <= UBound(var1Array, 1) And blnMatch = False
            If var2Array(i, 1) = var1Array(j, 1) Then
                blnMatch = True
                Exit Do
            End If
            j = j + 1
        Loop
        
        'Copy Dupes
        If blnMatch = True Then
            x = x + 1
            ws2.Cells(i, 1).EntireRow.Copy
            ws3.Cells(x, 1).PasteSpecial
        End If
 
   ElseIf (var2Array(i, 1) <> var2Array(i + 1, 1)) Then
        j = 1
        blnMatch = False
        Do While j <= UBound(var1Array, 1) And blnMatch = False
            If var2Array(i, 1) = var1Array(j, 1) Then
                blnMatch = True
                Exit Do
            End If
            j = j + 1
        Loop
        
        'Copy Dupes
         If (blnMatch = True And ws2.Cells(i, 5).Value > ws1.Cells(j, 5).Value And ws2.Cells(i, 8).Value <> False) Then
        'If blnMatch = True And ws2.Cells(i, 5).Value > ws1.Cells(j, 5).Value Then
            x = x + 1
            ws2.Cells(i, 1).EntireRow.Copy
            ws3.Cells(x, 1).PasteSpecial
            
            If ws3.Cells(x, 11).Value = "" Then
                'Do Nothing
            Else
            If (x <> 1 And (ws3.Cells(x, 11).Value = ws1.Cells(j, 8).Value)) Then
                ws3.Cells(x, 11).Interior.Color = 13561798
            Else
                ws3.Cells(x, 11).Interior.Color = 13551615
            End If
            End If
            
            If ws3.Cells(x, 12).Value = "" Then
                'Do Nothing
            Else
            If (ws3.Cells(x, 12).Value = ws1.Cells(j, 9).Value And x > 1) Then
                ws3.Cells(x, 12).Interior.Color = 13561798
            Else
                ws3.Cells(x, 12).Interior.Color = 13551615
            End If
            End If
            
            If ws3.Cells(x, 13).Value = "" Then
                'Do Nothing
            Else
            If (ws3.Cells(x, 13).Value = ws1.Cells(j, 10).Value And x > 1) Then
                ws3.Cells(x, 13).Interior.Color = 13561798
            Else
                ws3.Cells(x, 13).Interior.Color = 13551615
            End If
            End If
        End If
        
    End If
Next i
'-




'-------------------------------


Application.CutCopyMode = False


Application.ScreenUpdating = True


Worksheets("Results").Range("A" & LRow).AutoFilter


End Sub