Remove duplicates and merge rows-macro

[Annie1986]

A	B	C	D	E
2000	MaryP	123	street1,street2
2000	James S	123	street1
2000	Mary P	123	street1	2.8
2002	James S	abc	street1,street2
2003	Mary P	abc	street3,street4	1.8

<tbody>
</tbody>

I have above data in excel.I have to select row1 and row3 as duplicates,as Column B name is same instead of the space,Column A and Column C are same and column D is similar.Then I need to collect most and correct details and merge into 1 row

Expected result is

A	B	C	D	E
2000	Mary P	123	street1,street2	2.8
2000	James S	123	street1
2002	James S	abc	street1,street2
2003	Mary P	abc	street3,street4	1.8

<tbody>
</tbody>

Most and correct details
Correct Name- Mary P(with space)
Longest column D-street1,street2
Data in column E-2.8


Please suggest a macro as the number of rows is quite large.

 

[MickG]

If column "B" has Inaccurately spelt names, what other Inaccuracies can be expected, and is it possible to check the names against a known data base before any code is used to meet you thread requirements.

 

[Annie1986]

If column "B" has Inaccurately spelt names, what other Inaccuracies can be expected, and is it possible to check the names against a known data base before any code is used to meet you thread requirements.

I do not have known data base.I will have to see and understand it is duplicates.Other inaccuracy is ,the names can come with first part.In that case Mary P and Mary are same.

 

[jsotola]

"Mary P"  and "MaryP" are different

the two are similar though

what about "Mary" and "Maury"

those are also similar

if this is for a production environment then you cannot assume the two as being same

you could flag them for manual review

 

[Annie1986]

There wont be spelling errors.As far as I noted,either there wont be space between the first and the second part or the second part will be missing.

 

[Annie1986]

"Mary P"  and "MaryP" are different

the two are similar though

what about "Mary" and "Maury"

those are also similar

if this is for a production environment then you cannot assume the two as being same

you could flag them for manual review

There wont be spelling errors.As far as I noted,either there wont be space between the first and the second part or the second part will be missing.

 

[MickG]

Would it be acceptable to base the criteria on:- column "A", the first 4 characters in column "B" , and column "C"

 

[Annie1986]

Would it be acceptable to base the criteria on:- column "A", the first 4 characters in column "B" , and column "C"

column "A", the first 4 characters in column "B" ,column "C" and similar column D(some thing like most of the characters are same in column D)
There are times when A,B,C are same but description(column D) differs. Then they are not duplicates

 

[MickG]

Try this:-
Results start sheet2 "A2".

[COLOR="Navy"]Sub[/COLOR] MG21Dec20
[COLOR="Navy"]Dim[/COLOR] Rng         [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn          [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] n           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] oTx         [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Q           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Dic         [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Astr        [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Ac          [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    oTx = Dn & "," & Replace(Dn.Offset(, 1), " ", "") & "," & Dn.Offset(, 2)
      [COLOR="Navy"]If[/COLOR] Not .Exists(oTx) [COLOR="Navy"]Then[/COLOR]
           .Add oTx, Array(Dn, "")
        [COLOR="Navy"]Else[/COLOR]
            Q = .Item(oTx)
            Q(1) = IIf(InStr(Dn.Offset(, 1), " "), Dn.Offset(, 1), Q(1))
            [COLOR="Navy"]Set[/COLOR] Q(0) = Union(Q(0), Dn)
           .Item(oTx) = Q
        [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Dim[/COLOR] c       [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K       [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] G       [COLOR="Navy"]As[/COLOR] Variant
 
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
ReDim ray(1 To .Count, 1 To 5)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    c = c + 1
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] G [COLOR="Navy"]In[/COLOR] .Item(K)(0)
        [COLOR="Navy"]For[/COLOR] n = 1 To 5
            [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] n
                [COLOR="Navy"]Case[/COLOR] 2: ray(c, n) = IIf(.Item(K)(1) > "", .Item(K)(1), .Item(K)(0).Offset(, n - 1))
                [COLOR="Navy"]Case[/COLOR] 4
                    Astr = Split(G.Offset(, 3), ",")
                        [COLOR="Navy"]For[/COLOR] Ac = 0 To UBound(Astr)
                            Dic(Astr(Ac)) = Empty
                        [COLOR="Navy"]Next[/COLOR] Ac
                        ray(c, n) = Join(Dic.keys, ", ")
                [COLOR="Navy"]Case[/COLOR] 5: ray(c, n) = ray(c, n) + G.Offset(, n - 1)
                [COLOR="Navy"]Case[/COLOR] Else: ray(c, n) = G.Offset(, n - 1)
            [COLOR="Navy"]End[/COLOR] Select
        [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] G
Dic.RemoveAll
[COLOR="Navy"]Next[/COLOR] K
Sheets("Sheet2").Range("A2").Resize(.Count, 5) = ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick