试图找到唯一的ID以及其在excel中符合的所有值

Question

说实话，我不完全确定如何描述它是我正在尝试完成的？但是，无论如何，这是无论如何。我有一个Excel工作表，其中包含一列ID和第二列值需要关联到第一列。问题是A列中的ID包含重复项，这是可以的，因为一个ID可以符合多个值。我需要的是有一个第三列撤回唯一的ID，第四列拉回所有值的分号分隔列表的id符合资格。希望附加的图像有意义吗？为了什么值得我尝试每​​个我能想到的公式，而且我对宏的认识一无所知，这正是我所想要实现的。

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

这里的另一种方法，有几个优点

• 它builkds的唯一的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键 + F11从Excel）
• 表演项目资源管理器，如果其不可见（Ctrl + R）
• 添加Module（右键单击工作簿，插入模块）
• 打开模块（DBL点击）
• 添加Option Explicit作为第一行，如果不是已经有
• 复制此代码粘贴到模块

如何运行它，从Excel

• 激活表与您的数据
• 开放宏观d ialog（Alt键 + F8）
• 从列表中选择Demo和运行