Thread: Delete Duplicates and Concatenate Unique Cells

Hello,
This is my first post here - I have been searching around for quite a while for a solution, and I have found posts that are close, but because I don't know VB I am unable to modify them to work for my exact needs.

What I need is like this: http://www.excelforum.com/excel-prog...nd-delete.html
and
http://www.excelforum.com/excel-work...en-delete.html

Here's my data (I also attached a worksheet):
What I HAVE:
Term POS1 POS2 POS3 POS4 POS5 POS6
find NUM
fun ROY NNP
hello NN VB
hello NN JJ
try JJ
try NN


WHAT I WANT:
Term POS1
find NUM
fun ROY NNP
hello NN VB JJ
try JJ NN



The data is words with their part of speech labels, so I only want one entry per word, but need to concatenate the unique part of speech labels with each word.

I hope that makes sense - I would appreciate your help!

Thank you ,
Nathan

Select a cell in the table. From the Data tab select "Remove Duplicates" for Column A

Not sure what you mean by the rest

Yes, it is a little more complex than that.
What I have is two identical terms with extra columns that have unique data that I want to concatenate.



For example:
hello JJ VB
hello NN ROY VB

Would become:
hello JJ VB NN ROY

Is that a little clearer?

I found code that comes close to what I need for two columns, but I am not sure how to modify it for say, 5 or 6 columns (or however many I need) as well as remove duplicates. Can someone help?

Sub ConcatData()
Dim X As Double
Dim DataArray(5000, 2) As Variant
Dim NbrFound As Double
Dim Y As Double
Dim Found As Integer
Dim NewWks As Worksheet

Cells(1, 1).Select
Let X = ActiveCell.Row
Do While True
If Len(Cells(X, 1).Value) = Empty Then
Exit Do
End If
If NbrFound = 0 Then
NbrFound = 1
DataArray(1, 1) = Cells(X, 1)
DataArray(1, 2) = Cells(X, 2)
Else
For Y = 1 To NbrFound
Found = 0
If DataArray(Y, 1) = Cells(X, 1).Value Then
DataArray(Y, 2) = DataArray(Y, 2) & ", " & Cells(X, 2)
Found = 1
Exit For
End If
Next
If Found = 0 Then
NbrFound = NbrFound + 1
DataArray(NbrFound, 1) = Cells(X, 1).Value
DataArray(NbrFound, 2) = Cells(X, 2).Value
End If
End If
X = X + 1
Loop

Set NewWks = Worksheets.Add
NewWks.Name = "SummarizedData"
Cells(1, 1).Value = "Code"
Cells(1, 2).Value = "Colors Found"
X = 2
For Y = 1 To NbrFound
Cells(X, 1).Value = DataArray(Y, 1)
Cells(X, 2).Value = DataArray(Y, 2)
X = X + 1
Next
Beep
MsgBox ("Summary is done!")



End Sub

Here is another approach. Puts results in K1.

Sub x()

Dim oDic As Object, vData As Variant, vOut, n As Long, i As Long, j As Long

Set oDic = CreateObject("Scripting.Dictionary")

vData = Range("A1").CurrentRegion.Value
ReDim vOut(1 To UBound(vData, 1), 1 To 2)

With oDic
    For i = 1 To UBound(vData, 1)
        If Not IsEmpty(vData(i, 1)) And Not .Exists(vData(i, 1)) Then
            n = n + 1
            .Add vData(i, 1), n
            vOut(n, 1) = vData(i, 1)
            For j = 2 To UBound(vData, 2)
                If Len(vData(i, j)) = 0 Then Exit For
                vOut(n, 2) = vOut(n, 2) & " " & vData(i, j)
            Next j
        ElseIf .Exists(vData(i, 1)) Then
            For j = 2 To UBound(vData, 2)
                If Len(vData(i, j)) = 0 Then Exit For
                If InStr(vOut(.Item(vData(i, 1)), 2), " " & vData(i, j) & " ") = 0 Then
                    vOut(.Item(vData(i, 1)), 2) = vOut(.Item(vData(i, 1)), 2) & " " & vData(i, j)
                End If
            Next j
        End If
    Next i
End With

Range("K1").Resize(n, 100) = vOut
Columns("L:L").TextToColumns Destination:=Range("L1"), DataType:=xlDelimited, _
               TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
               Semicolon:=False, Comma:=False, Space:=True, Other:=False
Columns("L:L").Delete

End Sub

EDIT: amended slightly, ignore my previous comment about 100 limit, completely wrong!

Maybe this gives the same result:

Sub snb()
  sq = Cells(1).CurrentRegion

  For j = 1 To UBound(sq)
    c02 = ""
    For jj = 2 To UBound(sq, 2)
      c02 = c02 & "|" & sq(j, jj)
    Next
              
    If InStr(c01, sq(j, 1)& "|") = 0 Then
      c01 = c01 & vbCr & sq(j, 1) & c02
    Else
      c01 = Replace(c01, Join(Filter(Split(c01, vbCr), sq(j, 1) & "|"), ""), Join(Filter(Split(c01, vbCr), sq(j, 1) & "|"), "") & c02)
    End If
  Next

  cells(1,10).resize(ubound(split(c01,vbcr)))=application.transpose(split(mid(c01,2),vbcr)
End Sub