将重复名称编辑为每行一个

Question

我遇到了麻烦，我需要运行遍历重复的行，但每行保留一个名称并寻找一种快速的方法来做到这一点？例如，Harris Fuller 将排在第一行，但第二行将仅显示 Emma Anderson，但由于名字的长度各不相同，因此不确定如何解决这个问题，我们将不胜感激。

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

预期结果

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

目前已尝试拆分名称的代码

Sub SplitString()

Dim Name As Variant

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

Answer 1

您可以使用 Microsoft 365 尝试使用以下公式来提取唯一名称，然后将值复制并粘贴到原始列中。

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

Answer 2

转换为唯一数据

这对于您的简单数据样本来说有点过分了，但如果您在前两列中有数据组，您就会看到它的强大功能。

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

将重复名称编辑为每行一个

Edit duplicate names to one per row

excel

vba

excel-formula

转换为唯一数据