create unique row in excel

G2K

Active Member
Joined
May 29, 2009
Messages
355
hi all,

i have data in worksheet in tabular format like

<TABLE dir=ltr borderColor=#05ad00 cellSpacing=1 cellPadding=2 width=269 border=1><TBODY><TR><TD width="25%" height=16>
JobName​
</TD><TD width="25%" height=16>
JobType​
</TD><TD width="25%" height=16>
Machine​
</TD><TD width="25%" height=16>
Worker​
</TD></TR><TR><TD width="25%" height=16>
A​
</TD><TD width="25%" height=16>
J1​
</TD><TD width="25%" height=16>
M1​
</TD><TD width="25%" height=16>
xyz​
</TD></TR><TR><TD width="25%" height=16>
A​
</TD><TD width="25%" height=16>
J1​
</TD><TD width="25%" height=16>
M1​
</TD><TD width="25%" height=16>
wxy​
</TD></TR><TR><TD width="25%" height=16>
A​
</TD><TD width="25%" height=16>
J1​
</TD><TD width="25%" height=16>
M1​
</TD><TD width="25%" height=16>
pqr​
</TD></TR></TBODY></TABLE>

i want to keep all workers name in one cell seperated by comma and remove remaining two rows. the output data should look like -

<TABLE dir=ltr borderColor=#02ad00 cellSpacing=1 cellPadding=2 width=283 border=1><TBODY><TR><TD width="24%" height=16>
JobName​
</TD><TD width="24%" height=16>
JobType​
</TD><TD width="24%" height=16>
Machine​
</TD><TD width="29%" height=16>
Worker​
</TD></TR><TR><TD width="24%" height=16>
A​
</TD><TD width="24%" height=16>
J1​
</TD><TD width="24%" height=16>
M1​
</TD><TD width="29%" height=16>
xyz,wxy,pqr​
</TD></TR></TBODY></TABLE>

thanks in advance
 

jbeaucaire

Well-known Member
Joined
May 8, 2002
Messages
6,012
Is your data properly sorted like shown above, so like JobName/JobType/Machine are listed in the data together? If so, this simple consolidation routine will do what you want:
Code:
Option Explicit
Sub Consolidate()
'JBeaucaire (7/2/2009)
'Merge multi data matching column A & B & C into single row, column D concatenated
Dim LR As Long, i As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False

    For i = LR To 2 Step -1
        If Cells(i, "A").Value = Cells(i - 1, "A").Value And _
          Cells(i, "B").Value = Cells(i - 1, "B").Value And _
            Cells(i, "C").Value = Cells(i - 1, "C").Value Then
                Cells(i - 1, "D") = Cells(i - 1, "D") & "," & Cells(i, "D")
                Rows(i).Delete
        End If
    Next i

Application.ScreenUpdating = True
End Sub
Excel Workbook
ABCD
1JobNameJobTypeMachineWorker
2AJ1M1xyz
3AJ1M1wxy
4AJ1M1pqr
5BJ2M2ddd
6BJ2M2aaa
7CJ1M1123
8DJ2M2xyz
9DJ2M2wxy
10DJ3M2ddd
11DJ3M2aaa
BEFORE
Excel Workbook
ABCD
1JobNameJobTypeMachineWorker
2AJ1M1xyz,wxy,pqr
3BJ2M2ddd,aaa
4CJ1M1123
5DJ2M2xyz,wxy
6DJ3M2ddd,aaa
AFTER
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Hi, Your data columns "A to D" , Results start Column "F"
Code:
[COLOR="Navy"]Sub[/COLOR] MG02Jul41
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Q, v, c [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
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        .Add Dn.Value, Array(Dn.Next, Dn.Next.Next, Dn.Next.Next.Next)
    [COLOR="Navy"]Else[/COLOR]
        Q = .Item(Dn.Value)
        Q(2) = Q(2) & ", " & Dn.Offset(, 3)
        .Item(Dn.Value) = Q
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] v [COLOR="Navy"]In[/COLOR] .keys
        c = c + 1
        Cells(c, "F").Value = v
            Cells(c, "G").Value = .Item(v)(0)
                Cells(c, "H").Value = .Item(v)(1)
                    Cells(c, "I").Value = .Item(v)(2)
    [COLOR="Navy"]Next[/COLOR] v
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 

Forum statistics

Threads
1,081,526
Messages
5,359,287
Members
400,524
Latest member
Excelbat

Some videos you may like

This Week's Hot Topics

  • VBA (Userform)
    Hi All, I just would like to know why my code isn't working. Here is my VBA code: [CODE=vba]Private Sub OKButton_Click() Dim i As Integer...
  • List box that changes fill color
    Hello, I have gone through so many pages trying to figure this out. I have a 2020 calendar that depending on the day needs to have a certain...
  • Remove duplicates and retain one. Cross-linked cases
    Hi all I ran out of google keywords to use and still couldn't find a reference how to achieve the results of a single count. It would be great if...
  • VBA Copy and Paste With Duplicates
    Hello All, I'm in need of some input. My VBA skills are sub-par at best. I've assembled this code from basic research and it works but is...
  • Macro
    is it possible for a macro to run if the active cell value is different to the value above it
  • IF DATE and TIME
    I currently use this to check if date has passed but i also need to set a time on it too. Is it possible? [CODE=vba]=IF(B:B>TODAY(),"Not...
Top