Excel 2010 - Copy unique rows from sheet A to sheet B

Fishboy

Well-known Member
Joined
Feb 13, 2015
Messages
4,261
Hi all,

I have recently been trying to find a way to consolidate data from 2 worksheets into 1, keeping only the unique data in the final product. This thread caught my eye but it had been so long since I read the forum rules I rudely and foolishly asked my question in there at which point I was advised to start my own thread on the subject, so here goes:

In my spreadsheet I have a macro which clears the contents of a sheet labelled "Imported Sales Data", and then it imports a CSV file into the sheet.

I have another macro which currently clears the contents of a second sheet, labelled "Raw Sales Data", then copies the contents of "Imported Sales Data" over the top of "Raw Sales Data". All of this is working as intended, however it has been brought to my attention that we need to start collating the imported data so that we are adding to the end of existing data rather than simply wiping and overwriting it.

I had originally hoped I could make this easier by finding a column with unique values to be compared across sheets however there is definitely at least one value repeated somewhere in every possible column. The only truly unique factors are the entire rows themselves. So this leads me to my query...

How would I write a macro that compares "Imported Sales Data" columns A:H with "Raw Sales Data" columns A:H to find unique rows, then copy only those unique rows across to the bottom of "Raw Sales Data"?

Ideally I would also be looking to close the macro off with clearing the contents of "Imported Sales Data" so I can cut out the additional bloat of erroneous data that is bumping the file size up and slowing everything down.

Any help would be greatly appreciated
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

Fishboy

Well-known Member
Joined
Feb 13, 2015
Messages
4,261
Hi SteveO59L,

The data can be broken down as follows:


  • Column A is the name of a product that has been sold. This column will have many duplicates, one for each sale. Column header of ITEM
  • Column B is the size of the stack of product that was sold. Again, this will have duplicates. Column header of STACK SIZE
  • Column C is the quantity of the product that has been bought. More duplicates here. Column header of QUANTITY
  • Column D hows the price that the product was sold at. There is not a set price as the items were auctioned. Column header of PRICE
  • Column E shows the name of the buyer. The same customer may well have bought multiple items, or the same item more than once, so I expect duplicates here as well. Column header of BUYER
  • Column F shows who sold them the product. Column header of SELLER
  • Column G shows an epoch timestamp which is the closest thing to a unique value, however it does not account for seconds and therefore there can be duplicates if 2 sales happened during the same minute. Column header of TIME

Realistically there is no one column that can be used as a unique identifier, it will need to be a combination of all of these columns to work out which rows are unique, e.g:

Item A sold 40 units in 2 stacks of 20 for price X, on (DATE/TIME) bought by MysteryBuyer sold by TopSalesMan
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,311
I did a little research on this topic and found a macro and a function written by JoeMo on 10/25/2010. I've made a couple of simple changes to suit your needs. Copy them into a regular module and run the macro. Give it a try and see if it works for you.
Code:
Sub CompareSheets2()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Written by JoeMo 10/25/2010
'Compares 2 worksheets in same workbook to see if Sheet2 differs from Sheet1
'If sheet2 has a different usedrange than sheet1, the user has the option
'of exiting the sub or comparing only the usedrange of sheet1 to the same range in sheet2.
'If there are merged cells in either sheet, the cells are unmerged to make a comparison.
'This is necessary because in using Range.SpecialCells(xlCellTypeBlanks)on
'cells in Sheet1, VBA will include all merged cells in Range, even if they are not empty.
'After all comparisons are made, the cells that were unmerged are merged again
'to restore the original state of merged cells on both sheets.
'Any differences found in sht2 are given a cell fill with a color specific to the cell
'contents (i.e., error value, formula, constant, cell comment, ...).
'IF CELL COMMENTS ARE EDITED IN SHEET2 (i.e. changed from sheet1), THEY WILL BE
'DETECTED. HOWEVER, IF NEW COMMENTS ARE ADDED TO SHEET2, THE CELLS CONTAINING THEM
'WILL NOT BE IDENTIFIED (not worth the effort since added comments do not change
'the functionality of the sheet)EXCEPT TO SIGNAL IF THE TOTAL CELL COMMENT
'COUNT ON SHEET2 DIFFERS FROM THE TOTAL CELL COMMENT COUNT ON SHEET1.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim sht1 As Worksheet, sht2 As Worksheet, S1 As String, S2 As String
Dim rng1 As Range, rng2 As Range
Dim rng1b As Range, rng1e As Range, rng1f As Range
Dim rng1c As Range, rng1n As Range
Dim mRng1() As Range, mRng2() As Range, mR1 As Long, mR2 As Long, delta As Long
Dim N1 As Long, N2 As Long
Dim Adr1 As String, Adr2 As String
Dim Answer As Integer, msg As String
Dim DiffListB As String, DiffListE As String, DiffListF As String
Dim DiffListC As String, DiffListM As String, DiffListN As String, co As String
Dim mergedCels As Boolean, M1 As Boolean, M2 As Boolean
Dim calcState As Integer

Set sht1 = ActiveWorkbook.Sheets("Imported Sales Data")
Set sht2 = ActiveWorkbook.Sheets("Raw Sales Data")
Set rng1 = sht1.UsedRange
Set rng2 = sht2.UsedRange
Adr1 = rng1.Address
Adr2 = rng2.Address

'Compare Used Ranges
If Adr1 <> Adr2 Then
    msg = sht2.Name & " covers range " & Adr2 & " while " & sht1.Name & " covers range " & Adr1
    msg = msg & vbCrLf & vbCrLf & "Do you want to check for differences in cells within the usedrange of " & sht1.Name
    Answer = MsgBox(msg, vbYesNo)
    If Answer = vbNo Then Exit Sub
End If
'Check for merged cells
M1 = HasMergedCells(rng1)
M2 = HasMergedCells(rng2)
If M1 = M2 Then
    Select Case M1
        Case True: MsgBox "Both sheets have merged cells.": mergedCels = True
        Case False: MsgBox "Neither sheet has merged cells.": mergedCels = False
    End Select
Else
    Select Case M1
        Case True: MsgBox sht1.Name & " has merged cells while " & sht2.Name & " has none.": mergedCels = True
        Case False: MsgBox sht1.Name & " has no merged cells while " & sht2.Name & " has merged cells.": mergedCels = True
    End Select
End If
calcState = Application.Calculation
Application.Calculation = xlCalculationManual
'Unmerge any merged cells to make cell by cell comparison; restore merges later
'Also make merged cells comparison
If mergedCels Then
    DiffListM = ""
    Application.StatusBar = "UNMERGING MERGED CELLS TO ALLOW COMPARISON- THIS MAY TAKE AWHILE"
    For Each cel In rng1
        If cel.MergeCells Then
            mR1 = mR1 + 1
            ReDim Preserve mRng1(1 To mR1)
            Set mRng1(mR1) = cel.MergeArea
            If Not sht2.Range(mRng1(mR1).Address).MergeCells Then
                sht2.Range(mRng1(mR1).Address).Interior.ColorIndex = 45
                DiffListM = DiffListM & ", " & mRng1(mR1).Address
            End If
                
        End If
    Next cel
    Application.ScreenUpdating = False
    For Each cel In rng2
        If cel.MergeCells Then
            mR2 = mR2 + 1
            ReDim Preserve mRng2(1 To mR2)
            Set mRng2(mR2) = cel.MergeArea
            If Not sht1.Range(mRng2(mR2).Address).MergeCells Then
                mRng2(mR2).Interior.ColorIndex = 45
                DiffListM = DiffListM & ", " & mRng2(mR2).Address
            End If
        End If
    Next cel
    If M1 And M2 Then
        delta = UBound(mRng1) - UBound(mRng2)
    ElseIf M1 And Not M2 Then
        delta = UBound(mRng1)
    ElseIf Not M1 And M2 Then
        delta = -UBound(mRng2)
    End If
    Select Case delta
        Case 0: MsgBox "Same merged cells count in both sheets!"
        Case Is > 0: MsgBox delta & " more merged cells in " & sht1.Name & " than in " & sht2.Name
        Case Is < 0: MsgBox Abs(delta) & " fewer merged cells in " & sht1.Name & " than in " & sht2.Name
    End Select
    If Not DiffListM = "" Then
        msg = "The following cells in " & sht2.Name & " are either not merged like their counterparts in " & sht1.Name _
        & " or are merged unlike their counterparts in " & sht1.Name & ":" & vbNewLine
        msg = msg & Right(DiffListM, Len(DiffListM) - 1) & vbNewLine & "These cells are highlighted with an orange fill."
    End If
rng1.MergeCells = False
rng2.MergeCells = False
Application.ScreenUpdating = True
Application.StatusBar = False
End If

'
'Compare Error values
DiffListE = ""
On Error Resume Next
Set rng1e = rng1.SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0
If Not rng1e Is Nothing Then
    For Each cel In rng1e
        Adr1 = cel.Address
        If Not IsError(sht2.Range(Adr1)) Then
            sht2.Range(Adr1).Interior.ColorIndex = 8
            DiffListE = DiffListE & ", " & Adr1
        ElseIf CVErr(cel) <> CVErr(sht2.Range(Adr1)) Then
            sht2.Range(Adr1).Interior.ColorIndex = 8
            DiffListE = DiffListE & ", " & Adr1
        End If
    Next cel
End If
If rng1e Is Nothing Then
    MsgBox "No error values found in " & sht1.Name
ElseIf DiffListE = "" Then
    MsgBox "No differences in error values found!"
Else
    msg = "Values in the following cells in " & sht2.Name & " differ from error values in the cells with the same address in " & sht1.Name & ":"
    MsgBox msg & vbNewLine & Right(DiffListE, Len(DiffListE) - 1) & vbNewLine & "These cells are highlighted with a cyan fill."
End If

'Blank Cells in sheet1
On Error Resume Next
Set rng1b = rng1.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rng1b Is Nothing Then
    For Each cel In rng1b
        Adr1 = cel.Address
        If Not IsEmpty(sht2.Range(Adr1)) Then
            sht2.Range(Adr1).Interior.ColorIndex = 4
            DiffListB = DiffListB & ", " & Adr1
        End If
    Next cel
End If
If DiffListB = "" Then
MsgBox "No differences found in blank cells!"
Else
msg = "The following cells in " & sht2.Name & " are not blank like the same cells in  " & sht1.Name & ":"
MsgBox msg & vbNewLine & Right(DiffListB, Len(DiffListB) - 1) & vbNewLine & "These cells are highlighted with a green fill."
End If
'Cells with comments (notes)
N1 = sht1.Comments.Count
N2 = sht2.Comments.Count
If N1 > 0 Or N2 > 0 Then
    Select Case N1 - N2
        Case Is > 0: MsgBox sht1.Name & " has " & N1 - N2 & " more cells with comments than " & sht2.Name
        Case Is < 0: MsgBox sht1.Name & " has " & N2 - N1 & " fewer cells with comments than " & sht2.Name
    End Select
    DiffListN = ""
    On Error Resume Next
    Set rng1n = rng1.SpecialCells(xlCellTypeComments)
    On Error GoTo 0
    If Not rng1n Is Nothing Then
        For Each cel In rng1n
            Adr1 = cel.Address
            On Error Resume Next
            co = sht2.Range(Adr1).Comment.Text
            If Err.Number = 0 Then
                If cel.Comment.Text <> co Then
                    sht2.Range(Adr1).Interior.ColorIndex = 17
                    DiffListN = DiffListN & ", " & Adr1
                End If
            Else  'No comment in the cell in sht2
                sht2.Range(Adr1).Interior.ColorIndex = 17
                    DiffListN = DiffListN & ", " & Adr1
            End If
            On Error GoTo 0
        Next cel
    End If
    If DiffListN = "" Then
    MsgBox "No differences found in cells with Comments (Notes)!"
    Else
    msg = "The following cells in " & sht2.Name & " differ with respect to cell comments from the cells with the same address in " & sht1.Name & ":"
    MsgBox msg & vbNewLine & Right(DiffListN, Len(DiffListN) - 1) & vbNewLine & "These cells are highlighted with a purple fill."
    End If
End If

'Formula Cells - only looks at formula cells in sht1. sht2 formulas
'not in sht1 will not be detected here unless they occupy a cell
'that is empty in sht1 or has a different value in sht1.
DiffListF = ""
On Error Resume Next
Set rng1f = rng1.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not rng1f Is Nothing Then
    For Each cel In rng1f
        Adr1 = cel.Address
        If cel.Formula <> sht2.Range(Adr1).Formula Then
            sht2.Range(Adr1).Interior.ColorIndex = 6
            DiffListF = DiffListF & ", " & Adr1
        End If
    Next cel
End If
If DiffListF = "" Then
MsgBox "No differences found in cells with formulas!"
Else
msg = "Formulas in the following cells in " & sht2.Name & " differ from formulas in the cells with the same address in " & sht1.Name & ":"
MsgBox msg & vbNewLine & Right(DiffListF, Len(DiffListF) - 1) & vbNewLine & "These cells are highlighted with a yellow fill."
End If

'Numbers, Text,logical values cells
DiffListC = ""
On Error Resume Next
Set rng1c = rng1.SpecialCells(xlCellTypeConstants, 7)
On Error GoTo 0
If Not rng1c Is Nothing Then
For Each cel In rng1c
    Adr1 = cel.Address
    If Not IsError(sht2.Range(Adr1)) Then
        If cel.Formula <> sht2.Range(Adr1).Formula Then 'use Formula instead of Value to detect cases where there is a constant in sht1 and a formula in sht2 that produces the sht1 value
            sht2.Range(Adr1).EntireRow.Copy Sheets("Imported Sales Data").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            DiffListC = DiffListC & ", " & Adr1
        End If
    Else
        sht2.Range(Adr1).Interior.ColorIndex = 7
        DiffListC = DiffListC & ", " & Adr1
    End If
Next cel
End If
If DiffListC = "" Then
    MsgBox "No differences found in cells with constants or logical values!"
Else
msg = "The following cells in " & sht2.Name & " differ in value and/or there is a formula in " & sht2.Name
msg = msg & " that is not present in " & sht1.Name & ":"
MsgBox msg & vbNewLine & Right(DiffListC, Len(DiffListC) - 1) & vbNewLine & "These cells are highlighted with a magenta fill if they contain an error value, and a red fill otherwise."
End If
'Reset any cells that originally were merged
Application.ScreenUpdating = False
If mergedCels Then
    If M1 Then
        For i = 1 To UBound(mRng1)
            mRng1(i).Merge
        Next i
    End If
    If M2 Then
        For i = 1 To UBound(mRng2)
            mRng2(i).Merge
        Next i
    End If
End If
MsgBox "Comparison of " & sht2.Name & " to " & sht1.Name & " has completed."
Application.ScreenUpdating = True
Application.Calculation = calcState
End Sub
Function HasMergedCells(rng As Range) As Boolean
HasMergedCells = False
For Each c In rng
    If c.MergeCells Then
        HasMergedCells = True
        Exit Function
    End If
Next c
End Function
 

Fishboy

Well-known Member
Joined
Feb 13, 2015
Messages
4,261
Hi Mumps, sorry for the delay in my reply. Thanks for all of your help however I ended up finding a workaround where I had a macro copy from 'Imported Sales Data' on to 'Raw Sales Data' and then do a remove duplicate action based on all columns to distinguish the unique rows.
 

Watch MrExcel Video

Forum statistics

Threads
1,130,292
Messages
5,641,384
Members
417,207
Latest member
Vxhaet

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
Top