excel - Trying to find unique IDs with all of the values it qualifies for in excel

Question

To be quite honest I am not entirely sure how to describe what it is I am trying to accomplish? But, here it goes anyway. I have an excel sheet containing one column of IDs and a second column of values that need to be associated to the first column. The problem is that the IDs in column A contain duplicates, which is okay because one ID can qualify for multiple values. What I need is to have a third column pull back the unique id, and a fourth column pull back a semi-colon delimited list of all of the values the id qualifies for. Hopefully the attached image makes sense? For what it's worth I have tried every formula I can think of, and I really know nothing about macros, which is what I am thinking needs to be implemented.

Answer 1

试试下面的代码：

Sub sample()

    Dim lastRowA As Long, lastRowC As Long
    lastRowA = Range("A" & Rows.Count).End(xlUp).Row
    lastRowC = Range("C" & Rows.Count).End(xlUp).Row

    Dim rng As Range, cell As Range
    Set rng = Range("C2:C" & lastRowC)

    Dim rngSearch As Range
    Set rngSearch = Range("A1:A" & lastRowA)

    Dim rngFind As Range

    Dim firstCell As String

    For Each cell In rng

        Set rngFind = rngSearch.Find(What:=cell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
        If Not rngFind Is Nothing Then
            temp = rngFind.Offset(0, 1)
            firstCell = rngFind.Address

            Do While Not rngFind Is Nothing

                Set rngFind = rngSearch.FindNext(After:=rngFind)

                If rngFind.Address <> firstCell Then
                    temp = temp & ";" & rngFind.Offset(0, 1)
                Else
                    Set rngFind = Nothing
                End If
            Loop

        End If

        cell.Offset(0, 1) = temp
    Next

End Sub

Answer 2

这是另一种方法，它有几个优点

• 它构建了唯一 sku 的列表
• 它从列中清除旧数据C:D
• 它会比在一个范围内循环运行得快得多

---

Sub Demo()
    Dim rngA As Range, rng as Range
    Dim datA As Variant
    Dim i As Long
    Dim sh As Worksheet
    Dim dic As Object

    Set sh = ActiveSheet  ' can change this to your worksheet of choice
    Set dic = CreateObject("Scripting.Dictionary")

    With sh
        ' Get data from columns A:B into a variant array
        Set rngA = .Range(.Cells(2, 2), .Cells(.Rows.Count, 1).End(xlUp))
        datA = rngA

        ' Create list of unique sku's and built value strings
        For i = 1 To UBound(datA)
            If dic.Exists(datA(i, 1)) Then
                dic(datA(i, 1)) = dic(datA(i, 1)) & ";" & datA(i, 2)
            Else
                dic.Add datA(i, 1), datA(i, 2)
            End If
        Next

        ' Clear exisating data from columns C:D
        Set rng = .Range(.Cells(2, 4), .Cells(.Rows.Count, 3).End(xlUp))
        If rng.Row > 1 Then
            rng.Clear
        End If

        ' Put results into columns C:D
        .Range(.Cells(2, 3), .Cells(dic.Count + 1, 3)) = Application.Transpose(dic.Keys)
        .Range(.Cells(2, 4), .Cells(dic.Count + 1, 4)) = Application.Transpose(dic.Items)
    End With
End Sub

如何添加这个：

• 启动 VBS 编辑器 ( Alt+ F11from excel)
• 显示项目资源管理器，如果它不可见（Ctrl+ R）
• 添加一个Module（右键单击您的工作簿，插入，模块）
• 打开模块（dbl 点击）
• 添加Option Explicit为第一行，如果还没有的话
• 将此代码复制粘贴到模块中

如何从 Excel 运行它

• 使用您的数据激活工作表
• 打开宏对话框 ( Alt+ F8)
• 从列表中选择Demo并运行