De-duplication across multiple columns using VBA

SHaun687

New Member
Joined
Apr 18, 2017
Messages
7
Hi,

I am new to VBA and have been trying to right some code that will automate the formatting of some semi-structured data. The big issue I have is with de-duplication. I am trying de duplicate data based on one column and merge additional columns onto one row. For example (simplified data)


-- removed inline image ---


Becomes


-- removed inline image ---


I know I am probably going to have to assign values to the blanks in column A to stop blanks being seen as duplicates. The main problem I have with any code to date is that when the first row in column B, C or D is blank, no data is returned. For example in the above, "Name 1" would show as Name1, X, Blank, Blank.

Any help would be much appreciated! Thanks in advance.
 

SHaun687

New Member
Joined
Apr 18, 2017
Messages
7
Sorry - image did not attach!

Hi,

I am new to <acronym title="visual basic for applications">VBA</acronym> and have been trying to right some code that will automate the formatting of some semi-structured data. The big issue I have is with de-duplication. I am trying de duplicate data based on one column and merge additional columns onto one row. For example (simplified data)

ABCD
Name1X
Name1Y3
Name1X
1
4
Name2Z2
Name35
Name2Z

<tbody>
</tbody>

Becomes

ABCD
1
4
Name1XY3
Name2Z2
Name35

<tbody>
</tbody>


I know I am probably going to have to assign values to the blanks in column A to stop blanks being seen as duplicates. The main problem I have with any code to date is that when the first row in column B, C or D is blank, no data is returned. For example in the above, "Name 1" would show as Name1, X, Blank, Blank.

Any help would be much appreciated! Thanks in advance.
 
Last edited by a moderator:

vmjan02

Active Member
Joined
Aug 15, 2012
Messages
495
Dear Shaun687.

ref the link
[h=3]https://www.mrexcel.com/forum/excel-questions/999447-unique-values-1-column.html[/h]
I hope this will be help to you.
 

SHaun687

New Member
Joined
Apr 18, 2017
Messages
7
Hi vmjan02,

Thanks for your help - I've just realised my images were not included in the original post for some reason. What I am trying to do is as follows

Name1 A 5
Name1 A Z
Name1 5

Name2
Name2 B

Becomes
Name1 A 5 Z
Name2 B

So it is slightly different to just returning unique values as the values must still be assigned to a variable, in this case the "Name".

Kind regards
Shaun687
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Try this:-
Your data in columns "A to D"
Results start "F1".
Code:
[COLOR="Navy"]Sub[/COLOR] MG18Apr55
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, R [COLOR="Navy"]As[/COLOR] Range, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic  [COLOR="Navy"]As[/COLOR] Object, nDic [COLOR="Navy"]As[/COLOR] Object, nAc [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not IsEmpty(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
            Dic.Add Dn.Value, Dn
        [COLOR="Navy"]Else[/COLOR]
            [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = Union(Dic(Dn.Value), Dn)
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
ReDim ray(1 To Rng.Count, 1 To 2)
[COLOR="Navy"]Set[/COLOR] nDic = CreateObject("scripting.dictionary")
nDic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
    c = c + 1: nAc = 1
    ray(c, 1) = K
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Dic(K)
        [COLOR="Navy"]For[/COLOR] Ac = 1 To 3
           [COLOR="Navy"]If[/COLOR] Not nDic.exists(R.Offset(, Ac).Value) And Not R.Offset(, Ac).Value = "" [COLOR="Navy"]Then[/COLOR]
               nAc = nAc + 1
               nDic.Add (R.Offset(, Ac).Value), Nothing
               [COLOR="Navy"]If[/COLOR] nAc > UBound(ray, 2) [COLOR="Navy"]Then[/COLOR] ReDim Preserve ray(1 To Rng.Count, 1 To UBound(ray, 2) + 1)
               ray(c, nAc) = R.Offset(, Ac).Value
           [COLOR="Navy"]End[/COLOR] If
       [COLOR="Navy"]Next[/COLOR] Ac
    [COLOR="Navy"]Next[/COLOR] R
[COLOR="Navy"]Next[/COLOR] K
Range("F1").Resize(c, UBound(ray, 2)).Value = ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Last edited by a moderator:

SHaun687

New Member
Joined
Apr 18, 2017
Messages
7
Hi Mick,

That's brilliant - thank you so much! Just one more question, how could I alter the above so that data remains in the column it was found. For example

Name1 X
Name1 Z

is returned as Name1 X Z as opposed to
Name1 X Z

No worries if this could end up being more hassle than it's worth as I can apply formatting at this stage rather than before the de-duplication. Your code has been of huge help thanks!
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Do you mean this:-
This:-
Name1A5
Name1AZ
Name15k
Returns this:-
Name1A, 5Z, K
<colgroup><col width="64" style="width: 48pt;" span="3"> <tbody> </tbody>

Or something else ???
 

SHaun687

New Member
Joined
Apr 18, 2017
Messages
7
Yes pretty much that, although the data unfortunately contains a lot of blanks so likely to be more like the following (blank column deliberate)

This:-
Name1A
Name1A5Z
Name1K
Returns:-
Name1A5Z,K

<tbody>
</tbody>

Hope that makes sense?
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Try this:-
Results now start column "K", alter wher shown shown.
As your example now shows 5 columns, I've changed the possible columns to 6, Change this where shown in code to suit.
Code:
[COLOR="Navy"]Sub[/COLOR] MG18Apr06
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, R [COLOR="Navy"]As[/COLOR] Range, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic  [COLOR="Navy"]As[/COLOR] Object, nDic [COLOR="Navy"]As[/COLOR] Object, nAc [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not IsEmpty(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
            Dic.Add Dn.Value, Dn
        [COLOR="Navy"]Else[/COLOR]
            [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = Union(Dic(Dn.Value), Dn)
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
ReDim ray(1 To Rng.Count, 1 To 6) '[COLOR="Green"][B] Change this "6" (number of columns in Data) to suit[/B][/COLOR]
[COLOR="Navy"]Set[/COLOR] nDic = CreateObject("scripting.dictionary")
nDic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
    c = c + 1
    ray(c, 1) = K
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Dic(K)
        [COLOR="Navy"]For[/COLOR] Ac = 2 To UBound(ray, 2)
           [COLOR="Navy"]If[/COLOR] Not nDic.exists(R(, Ac).Value) And Not R(, Ac).Value = "" [COLOR="Navy"]Then[/COLOR]
               nDic.Add (R(, Ac).Value), Nothing
               ray(c, Ac) = ray(c, Ac) & IIf(ray(c, Ac) = _
               "", R(, Ac).Value, " ," & R(, Ac).Value)
           [COLOR="Navy"]End[/COLOR] If
       [COLOR="Navy"]Next[/COLOR] Ac
    [COLOR="Navy"]Next[/COLOR] R
[COLOR="Navy"]Next[/COLOR] K
'[COLOR="Green"][B]Change range "K" to suit[/B][/COLOR]
[COLOR="Navy"]With[/COLOR] Range("K1").Resize(c, UBound(ray, 2))
    .Value = ray
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Last edited by a moderator:

Forum statistics

Threads
1,081,860
Messages
5,361,737
Members
400,653
Latest member
ProParadox

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top