Compare 2 Lists to Generate List of Updates

R

RNELSO2

New Member
Joined
Apr 10, 2017
Messages
4
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
[TABLE="width: 256"]
<tbody>[TR]
[TD="class: xl66, width: 64"]Year[/TD]
[TD="class: xl66, width: 64"]Model ID[/TD]
[TD="class: xl66, width: 64"] Code[/TD]
[TD="class: xl66, width: 64"]Version[/TD]
[/TR]
[TR]
[TD="class: xl65, align: right"]2018[/TD]
[TD="class: xl65, align: right"]1201[/TD]
[TD="class: xl66"] 2T[/TD]
[TD="class: xl66"]C[/TD]
[/TR]
[TR]
[TD="class: xl65, align: right"]2018[/TD]
[TD="class: xl65, align: right"]1201[/TD]
[TD="class: xl66"] 3P[/TD]
[TD="class: xl66"]A[/TD]
[/TR]
[TR]
[TD="class: xl65, align: right"]2018[/TD]
[TD="class: xl65, align: right"]1201[/TD]
[TD="class: xl66"] 3P[/TD]
[TD="class: xl66"]B[/TD]
[/TR]
[TR]
[TD="class: xl65, align: right"]2018[/TD]
[TD="class: xl65, align: right"]1201[/TD]
[TD="class: xl66"] 3Z[/TD]
[TD="class: xl66"]A[/TD]
[/TR]
[TR]
[TD="class: xl65, align: right"]2018[/TD]
[TD="class: xl65, align: right"]1201[/TD]
[TD="class: xl66"] 63[/TD]
[TD="class: xl66"]A[/TD]
[/TR]
</tbody>[/TABLE]

Sheet 2 List 2
[TABLE="width: 256"]
<tbody>[TR]
[TD="class: xl65, width: 64"]Year[/TD]
[TD="class: xl65, width: 64"]Model ID[/TD]
[TD="class: xl65, width: 64"]Code[/TD]
[TD="class: xl65, width: 64"]Version[/TD]
[/TR]
[TR]
[TD="class: xl65"]2018[/TD]
[TD="class: xl65"]1201[/TD]
[TD="class: xl65"]GY[/TD]
[TD="class: xl65"]A[/TD]
[/TR]
[TR]
[TD="class: xl65"]2018[/TD]
[TD="class: xl65"]1201[/TD]
[TD="class: xl65"]H6[/TD]
[TD="class: xl65"]A[/TD]
[/TR]
[TR]
[TD="class: xl65"]2018[/TD]
[TD="class: xl65"]1201[/TD]
[TD="class: xl65"]2T[/TD]
[TD="class: xl65"]A[/TD]
[/TR]
[TR]
[TD="class: xl65"]2018[/TD]
[TD="class: xl65"]1201[/TD]
[TD="class: xl65"]2T[/TD]
[TD="class: xl65"]B[/TD]
[/TR]
[TR]
[TD="class: xl65"]2018[/TD]
[TD="class: xl65"]1201[/TD]
[TD="class: xl65"]H9[/TD]
[TD="class: xl65"]A[/TD]
[/TR]
[TR]
[TD="class: xl65"]2018[/TD]
[TD="class: xl65"]1201[/TD]
[TD="class: xl65"]63[/TD]
[TD="class: xl65"]B[/TD]
[/TR]
[TR]
[TD="class: xl65"]2018[/TD]
[TD="class: xl65"]1201[/TD]
[TD="class: xl65"]H4[/TD]
[TD="class: xl65"]A[/TD]
[/TR]
</tbody>[/TABLE]

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.

Code: 
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.
 

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
Sort by date Sort by votes
Try this for results on sheet3.
NB:- I'll let you add your own code as required.
Code: 
[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
 
Upvote 0
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?

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

Similar threads

L
  • Solved
Adding empty lines based on value via “I” loop which crashes and lags
2
Replies
10
Views
383
Joe4
Joe4
M
  • Question Question
How To Loop Macro
Replies
6
Views
468
rlv01
R
R
  • Solved
TextToColumns, VBA to uncheck "Treat consecutive delimiters as one"
Replies
5
Views
89
Joe4
Joe4
H
  • Solved
bug on the code
Replies
8
Views
220
Joe4
Joe4
K
  • Solved
Code to search job id from multiple sources and update main spreadsheet.
2
Replies
10
Views
594
mumps
mumps

Forum statistics

Threads
1,223,247
Messages
6,171,007
Members
452,374
Latest member
keccles

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