Trying to find unique IDs with all of the values i

问题:

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.

回答1:

Try below code :

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

回答2:

Here's an alternative approach, that has several advantages

• it builkds the list of unique sku's
• it clear old data from columns C:D
• it will run much faster than looping over a range

---

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

How to add this:

• Start the VBS editor (Alt+F11 from excel)
• show project explorer, if its not already visible (Ctrl+R)
• add a Module (right click on your workbook, Insert, Module)
• open the module (dbl click)
• Add Option Explicit as the first line, if not already there
• copy paste this code into module

How to run it, from Excel

• activate the sheet with your data
• open macro dialog (Alt+F8)
• select Demo from list and run