VBA Code to remove partial duplicate entries from data based on set criteria

[fishep6]

Hi What I am trying to achieve is a code that will remove semi duplicate rows of data from the attached spread sheet table, (Table 1) and then leave me the results as in (Table 2)
I am not sure whether I need to concatenate as part of the formula or not in order to get the objective to work. ORIGINAL DATA TABLE 1
First Name	Surname	Date Of Birth	Date Of Assessment	Gender	Smoker	Health
Dave	Smith	02/06/1977	14-May	Male	Yes	Good
Adam	Jones	03/03/1960	14-May	Male	Yes	Fair
Adam	Jones	03/03/1960	17-May	Male	No	Fair
Rose	Frank	12/05/1981	14-May	Female	No	Good
Ben	Jakes	06/07/1988	16-May	Male	Yes	Bad
Josh	West	12/02/1965	14-May	Male	No	Fair
Rita	Copeman	25/06/1978	14-May	Male	No	Good
Rita	Copeman	25/06/1978	22-May	Male	Unknown	Good
Shariq	Najeeb	04/11/1976	14-May	Male	Yes	Good
Columns (A,B and C) are the columns I want to check for duplicates, theColumn (F) will be the only real variable I am concerned with.
So in the example we can see that "Adam" and "Rita" each have a duplicate entry, however there they have differing values in column F which is what I am concerned with and they also have a differing value in column D which I am not concerned about.
What I want to do effectively, when a duplicate is listed is keep the first line that is entered and remove the duplicate line. However I also want the line that is remaining to have the following changes to the Smoker column.
I want the smoker column to then state the word "ERROR", followed by the text that is in both smoker columns for the duplicate entries, so you will see in the second table this is how I want the results to appear IDEAL OUTCOME TABLE 2
First Name	Surname	Date Of Birth	Date Of Assessment	Gender	Smoker	Health
Dave	Smith	02/06/1977	14-May	Male	Yes	Good
Adam	Jones	03/03/1960	14-May	Male	ERROR "Yes","No"	Fair
Rose	Frank	12/05/1981	14-May	Female	No	Good
Ben	Jakes	06/07/1988	16-May	Male	Yes	Bad
Josh	West	12/02/1965	14-May	Male	No	Fair
Rita	Copeman	25/06/1978	14-May	Male	ERROR "Yes","Unknown"	Good
Shariq	Najeeb	04/11/1976	14-May	Male	Yes	Good
So you will see my original table has reduced from 9 lines to 7 You will note for "Adam" there is now only one entry, colum (D) is using the date from the first entry in the original table, and then in column F is contains the text "ERROR" followed by the 2 duplicate entries from the previous table which were "Yes" and "No"
You will note for "Rita" there is now only one entry, colum (D) is using the date from the first entry in the original table, and then in column F is contains the text "ERROR" followed by the 2 duplicate entries from the previous table which were "No" and "Unknown"
My data table is a lot larger than the sample but hopefully this is possible? I am happy to get the data I want in table 2 to open on a separate tab on my spreadsheet if that is an easier approach?
Thank you in advance

<tbody>
</tbody>

 

[MickG]

Try this for results on sheet2:-

[COLOR="Navy"]Sub[/COLOR] MG22May03
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant
Ray = Cells(1).CurrentRegion.Resize(, 7)
ReDim nRay(1 To UBound(Ray, 1), 1 To UBound(Ray, 2))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(Ray, 1)
Txt = Ray(n, 1) & Ray(n, 2) & Ray(n, 3)
    [COLOR="Navy"]If[/COLOR] Not .Exists(Txt) [COLOR="Navy"]Then[/COLOR]
      c = c + 1
      [COLOR="Navy"]For[/COLOR] Ac = 1 To UBound(Ray, 2)
         nRay(c, Ac) = Ray(n, Ac)
      [COLOR="Navy"]Next[/COLOR] Ac
        .Add Txt, Array(Ray(n, 6), c)
    [COLOR="Navy"]Else[/COLOR]
       Q = .Item(Txt)
        Q(0) = Q(0) & ", """ & Ray(n, 6) & ""
       nRay(Q(1), 6) = "Error  """ & Q(0) & """"
    .Item(Txt) = Q
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 7)
  .Value = nRay
  .Columns.AutoFit
  .Borders.Weight = 2
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[fishep6]

Thank you that is amazing

I have a couple of tweaks I need to do if possible please?

1) Rather than columns A,B and C being the duplicates it is actually columns B,C and D, presumably I just change Txt = Ray(n, 1) & Ray(n, 2) & Ray(n, 3) to Txt = Ray(n, 2) & Ray(n, 3) & Ray(n, 4)???

2) Is there a way to get the formula to ignore this if the value in column 6 (F) is "NULL"???

3) What would I need toad to the end of the code in order to get a pop up box saying that the code has run and is completed?

Many thanks

 

[MickG]

Q(1) Basically Yes , but maybe a bit more required, I'll send some new code !!!
Q(2) Do you mean, Do NOT include this line in sheet2 results if column(6) has the actual string "Null" in it. ???
Q(3) No problem with this !!!!

 

[fishep6]

1) brilliant
2) - no if it has Null in the F column then the code just ignores it and takes the line over to the second sheet without trying to de duplicate it.
3) Thank you so much

 

[MickG]

Try this for data starting column "B1" and results in sheet2 starting "A1".

[COLOR="Navy"]Sub[/COLOR] MG22May23
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range
Ray = Cells(1).CurrentRegion.Offset(, 1).Resize(, 8)
ReDim nRay(1 To UBound(Ray, 1), 1 To UBound(Ray, 2))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(Ray, 1)
Txt = Ray(n, 1) & Ray(n, 2) & Ray(n, 3)
    [COLOR="Navy"]If[/COLOR] Not .Exists(Txt) [COLOR="Navy"]Then[/COLOR]
      c = c + 1
      [COLOR="Navy"]For[/COLOR] Ac = 1 To UBound(Ray, 2)
         nRay(c, Ac) = Ray(n, Ac)
      [COLOR="Navy"]Next[/COLOR] Ac
        .Add Txt, Array(Ray(n, 6), c)
    [COLOR="Navy"]Else[/COLOR]
       Q = .Item(Txt)
        [COLOR="Navy"]If[/COLOR] Q(0) = "Null" [COLOR="Navy"]Then[/COLOR]
            c = c + 1
            [COLOR="Navy"]For[/COLOR] Ac = 1 To UBound(Ray, 2)
                nRay(c, Ac) = Ray(n, Ac)
            [COLOR="Navy"]Next[/COLOR] Ac
        [COLOR="Navy"]Else[/COLOR]
            Q(0) = Q(0) & ", """ & Ray(n, 6) & ""
            nRay(Q(1), 6) = "Error  """ & Q(0) & """"
        [COLOR="Navy"]End[/COLOR] If
    .Item(Txt) = Q
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 7)
  .Value = nRay
  .Columns.AutoFit
  .Borders.Weight = 2
[COLOR="Navy"]End[/COLOR] With
MsgBox "Code Run Complete!!"
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick