試圖找到唯一的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和運行