Macro to Compare worksheets and copy unique rows to separate sheets

[stokeboy86]

Hi

I have been looking into automating a process to compare new price lists supplied by suppliers (this could be anything from a few hundred rows to several thousand) against an existing product list within an application.

I can create a workbook that has 2 x worksheets, "new product list" & "existing product list" and am looking for a macro that does 3 x things:

1. Check for matching product references in the 2 x worksheets, where there is a match, copy the row from the "new product list" that into a separate worksheet (this will be used to update existing prices)
2. Where there is unique data in the "new product list", copy into a separate worksheet (this indicates a newly introduced product that requires importing into the product list used by the application)
3. Where there is unique data in the "existing product list", copy into a separate worksheet (this indicates a discontinued stock that requires removing or flagging in the application)

The "new product list" is always supplied in a specific format, there are 26 x columns (A-Z) and the unique identifier (product reference) is in the 3rd column (C)

The "existing product list" will always be in the same format, this will have 13 x columns (A-M) with the unique identifier (product reference) in the 2nd column (B)

What would be really cool, is for an additional layer of logic for the "new products" (unique product references supplied in the "new product list"). The new product could be a new size of a product that exists in the application, in these cases the application would have a single stock code (something separate to the product reference for use in the application) that all the different sizes use.

Product information is stored in columns 7,11,10,15 (G, K, J, O) - this is "Brand", "Colour", "Weight" & "Thickness". If the contents of these fields could be concatenated and used to compare against the products in the "existing product list". The corresponding values in the "existing product list" are stored in columns 7, 8, 3, 4 (G, H, C, D).

If there is a match, the value of column 12 (L) in the "existing product" list - stock code - should also be copied to the new worksheet as an additional column 27 (AA). This would indicate the new product should be added as a "variation" of an existing product used by the application (Hope that makes sense!)

I think I know what I want to do, but not sure how to execute as I am not familiar with VBA or macros! I am hoping somebody may be able to help?!

Many thanks in advance!

 

[Fluff]

This should do the first part of your request.
If it's OK I can have a look at the second part

Sub CompareSplit()

    Dim Cl As Range
    Dim NPLSht As Worksheet
    Dim EPLSht As Worksheet
    Dim OldRng As Range
    Dim BothRng As Range
    Dim NewRng As Range
    Dim Itm As Variant

Application.ScreenUpdating = False

    Set NPLSht = Sheets("NewItem")
    Set EPLSht = Sheets("Exist")
    
    With CreateObject("scripting.dictionary")
        For Each Cl In NPLSht.Range("C2", NPLSht.Range("C" & Rows.Count).End(xlUp))
            If Not .exists(Cl.Value) Then .Add Cl.Value, Cl.Row
        Next Cl
        For Each Cl In EPLSht.Range("B2", EPLSht.Range("B" & Rows.Count).End(xlUp))
            If Not .exists(Cl.Value) Then
                If OldRng Is Nothing Then
                    Set OldRng = Cl
                Else
                    Set OldRng = Union(OldRng, Cl)
                End If
            Else
                If BothRng Is Nothing Then
                    Set BothRng = NPLSht.Rows(.Item(Cl.Value))
                Else
                    Set BothRng = Union(BothRng, NPLSht.Rows(.Item(Cl.Value)))
                End If
                .Item(Cl.Value) = vbNullString
            End If
        Next Cl
        For Each Itm In .items
            If Len(Itm) > 0 Then
                If NewRng Is Nothing Then
                    Set NewRng = NPLSht.Rows(Itm)
                Else
                    Set NewRng = Union(NewRng, NPLSht.Rows(Itm))
                End If
            End If
        Next Itm
    End With
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Old"
    OldRng.EntireRow.Copy Sheets("Old").Range("A1")
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Both"
    BothRng.Copy Sheets("Both").Range("A1")
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = "New"
    NewRng.Copy Sheets("New").Range("A1")

    
End Sub

 

[stokeboy86]

Hi Fluff,

Thanks for the reply!

I tried running the Macro, however there is a "Run-time error '13': Type mismatch"

When debugging, this refers to the line:

       Set BothRng = Union(BothRng, NPLSht.Rows(.Item(Cl.Value)))

Regards

 

[Fluff]

Can you have the same Unique indentifier more than once in either list?

 

[stokeboy86]

Ahhhh ok, the unique identifier should only occur once in each list, however this is not validated so could (and has in this case) have duplicate values.

Have cleaned the data and removed the duplicate values and the macro is working great, many thanks indeed!

Is it possible to also include the existing stock code (if applicable) in the "new" worksheet?

 

[Fluff]

Unfortunately, I don't have any data, that would be suitable for testing.
Could you upload your file to a file share site such as OneDrive or DropBox?

 

[stokeboy86]

Link to data: https://www.dropbox.com/sh/wobkp76izodftem/AAAPsEB1iqKOtfxiGpgZK-oya?dl=0

Many thanks!

 

[Fluff]

OK, thanks for the file.
I've made a couple of slight tweaks to the initial code

Sub CompareSplit()

    Dim Cl As Range
    Dim NPLSht As Worksheet
    Dim EPLSht As Worksheet
    Dim OldRng As Range
    Dim BothRng As Range
    Dim NewRng As Range
    Dim Itm As Variant

Application.ScreenUpdating = False

    Set NPLSht = Sheets("NewItem")
    Set EPLSht = Sheets("Exist")
    
    Set OldRng = Sheets("Exist").Range("A1")
    Set BothRng = Sheets("Newitem").Range("A1")
    Set NewRng = Sheets("Newitem").Range("A1")
    
    With CreateObject("scripting.dictionary")
        For Each Cl In NPLSht.Range("C2", NPLSht.Range("C" & Rows.Count).End(xlUp))
            If Not .exists(Cl.Value) Then .Add Cl.Value, Cl.Row
        Next Cl
        For Each Cl In EPLSht.Range("B2", EPLSht.Range("B" & Rows.Count).End(xlUp))
            If Not .exists(Cl.Value) Then
                Set OldRng = Union(OldRng, Cl)
            Else
                Set BothRng = Union(BothRng, NPLSht.Rows(.Item(Cl.Value)))
                .Item(Cl.Value) = vbNullString
            End If
        Next Cl
        For Each Itm In .items
            If Len(Itm) > 0 Then
                Set NewRng = Union(NewRng, NPLSht.Rows(Itm))
            End If
        Next Itm
    End With
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Old"
    OldRng.EntireRow.Copy Sheets("Old").Range("A1")
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Both"
    BothRng.EntireRow.Copy Sheets("Both").Range("A1")
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "New"
    NewRng.EntireRow.Copy Sheets("New").Range("A1")

    Call ConcatCompare
End Sub

This will also call the following sub

Sub ConcatCompare()
    Dim rw
    With Sheets("Exist")
        .Range("N2:N" & .Range("M" & Rows.Count).End(xlUp).Row).Formula = "=G2&H2&C2&D2"
    End With
 
    With Sheets("New")
        With .Range("AA2:AA" & .Range("Z" & Rows.Count).End(xlUp).Row)
            .Formula = "=G2&K2&J2&O2"
            .Offset(, 1).Value = Application.Match(.Value, Sheets("Exist").Columns(14), 0)
            .Offset(, 1).SpecialCells(xlConstants, xlErrors).ClearContents
            For Each rw In .Offset(, 1).SpecialCells(xlConstants, xlNumbers)
                rw.Value = Sheets("Exist").Range("L" & rw.Value).Value
            Next rw
        End With
        .Columns(27).Delete
    End With
    Sheets("exist").Columns(14).Clear
    
End Sub

Which can either go in the existing module, or a new module

 

[stokeboy86]

Hi Fluff

That is superb - exactly what I was after!

Many thanks indeed, I owe you a beer!

Regards

 

[Fluff]

Glad I could help & thanks for the feedback