Edit duplicate names to one per row-CodePudding

Im having trouble I need to run through rows of duplicates but keep one name per row and looking for a quick way to do this? For example Harris Fuller would be first row but the second row would only show Emma Anderson but as the names will be all different lengths not sure how to go about this any guidance would be appreciated.

Unit        Location      Name
75231111    Jukia         Harris Fuller, Emma Anderson
75231111    Jukia         Harris Fuller, Emma Anderson
75231111    Jukia         Tammy Weath, Leonie Polur, Phil Tebgan
75231111    Jukia         Tammy Weath, Leonie Polur, Phil Tebgan
75231111    Jukia         Tammy Weath, Leonie Polur, Phil Tebgan

Expected outcome

Unit        Location      Name
75231111    Jukia         Harris Fuller
75231111    Jukia         Emma Anderson
75231111    Jukia         Tammy Weath
75231111    Jukia         Leonie Polur
75231111    Jukia         Phil Tebgan

Attempted Code to split name so far

Sub SplitString()

Dim Name As Variant

Name = Split(Sheet1.Range("C2").Value, ",")

CodePudding user response：

You may try below formula with Microsoft 365 to extract unique names, then copy and paste as values in original column.

=FILTERXML("<t><s>"&TEXTJOIN("</s><s>",TRUE,SUBSTITUTE(C2:C6,",","</s><s>"))&"</s></t>","//s[not(preceding::*=.)]")

CodePudding user response：

Transform to Unique Data

It is overkill for your simple data sample but if you have groups of data in the first two columns, you'll see its power.

Option Explicit

Sub TransformToUnique()
    
    Const sFirstCellAddress As String = "A1"
    Const dFirstCellAddress As String = "A1"
    
    Dim uCols As Variant: uCols = VBA.Array(1, 2)
    Const vCol As Long = 3
    
    Const vDelimiter As String = ", "
    Const uDelimiter As String = "@"
    
    Dim sws As Worksheet: Set sws = Sheet1
    Dim dws As Worksheet: Set dws = Sheet2
    
    ' Write from the source range to the source array.
    
    Dim cUpper As Long: cUpper = UBound(uCols)
    Dim cCount As Long: cCount = cUpper   2
    Dim srg As Range
    Set srg = sws.Range(sFirstCellAddress).CurrentRegion.Resize(, cCount)
    Dim srCount As Long: srCount = srg.Rows.Count
    
    Dim sData As Variant: sData = srg.Value
    Dim dLen As Long: dLen = Len(uDelimiter)
    
    ' Write from the source array to a dictionary.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim cValue As Variant
    Dim cString As String
    Dim r As Long
    Dim c As Long
    Dim v As Long
    
    For r = 2 To srCount
        ' Join unique columns.
        For c = 0 To cUpper
            cValue = sData(r, uCols(c))
            If Not IsError(cValue) Then
                If c = 0 Then
                    cString = CStr(cValue)
                    If Len(cString) = 0 Then Exit For
                Else
                    cString = cString & uDelimiter & CStr(cValue)
                End If
            End If
        Next c
        ' Append split value columns.
        If c > 0 Then
            cValue = sData(r, vCol)
            If IsError(cValue) Then cValue = vbNullString
            If Len(cValue) > 0 Then
                dict(cString) = Empty
            Else
                cValue = Split(cValue, vDelimiter)
                For v = 0 To UBound(cValue)
                    dict(cString & uDelimiter & cValue(v)) = Empty
                Next v
            End If
        End If
    Next r

    ' Write from the dictionary to the destination array.

    Dim drcount As Long: drcount = dict.Count   1
    Dim dData As Variant: ReDim dData(1 To drcount, 1 To cCount)
    
    ' Write headers.
    For c = 1 To cCount
        dData(1, c) = sData(1, c)
    Next c
    Erase sData ' the rest is in the dictionary
    
    ' Write the rest.
    r = 1
    Dim Key As Variant
    For Each Key In dict.Keys
        r = r   1
        cValue = Split(Key, uDelimiter)
        For c = 1 To cCount
            dData(r, c) = cValue(c - 1)
        Next c
    Next Key
            
    ' Write from the destination array to the destination range.
    
    With dws.Range(dFirstCellAddress).Resize(, cCount)
        ' Copy data.
        .Resize(drcount).Value = dData
        ' Clear below.
        .Resize(dws.Rows.Count - .Row - drcount   1).Offset(drcount).Clear
        ' Apply some formatting.
        '.Font.Bold = True
        '.EntireColumn.AutoFit
    End With
    'ThisWorkbook.Save
    
    ' Inform.
    
    MsgBox "Unique data copied.", vbInformation
    
End Sub