Excel VBA 字典项连接

Question

我需要帮助理解字典，所以我尝试一些简单的东西。我有搜索和删除重复值的代码。

我将字典键存储为人员，将项目存储为 ID。想法是用数据循环到单元格范围，找到重复的值删除它们但连接项目（ID）。

如何从字典中获取具有 ID 和连接值的范围单元格的项目？我很感激和帮助，链接，教程，建议

到目前为止的代码：

Option Explicit

Sub DictionaryTest()
    
    Dim dict As Scripting.Dictionary
    Dim rowCount As Long
    Dim People As String
    Dim ID As Integer
    Dim item As Variant
    
    Set dict = New Scripting.Dictionary
    
    rowCount = Cells(Rows.Count, "E").End(xlUp).Row
    
    'Debug.Print rowCount
    
    Do While rowCount > 1
    
        People = Sheet2.Cells(rowCount, "E").Value
        ID = Sheet2.Cells(rowCount, "D").Value
        
        If dict.Exists(People) Then
            'Sheet2.Rows(rowCount).EntireRow.Delete
            
        Else
            dict.Add People, ID
        End If
        
        rowCount = rowCount - 1
        
    Loop
    
End Sub

谢谢！

Answer 1

我正在处理此代码并对其进行一些更新。我看到重复字典中的立即窗口项是连接的，因此代码可以完全按照我的意愿工作，但我不知道如何在单元格中连接该值。在字典中，键是 People，Item 是 ID

这是我在许多代码测试中得到的最好结果。

Sub DictTest()

Dim dict As Scripting.Dictionary
Dim rowsCount As Long
Dim People As String, id As Integer


Set dict = New Scripting.Dictionary

rowsCount = Cells(Rows.Count, "D").End(xlUp).Row
People = Sheet2.Cells(rowsCount, "D").Value

    Do While rowsCount > 1
        People = Sheet2.Cells(rowsCount, "D").Value
        id = Sheet2.Cells(rowsCount, "C")
        
            'if duplicate value is found then concatenate Item value
            If dict.Exists(People) Then
                dict(People) = dict(People) & "," & " " & id
               
                Debug.Print dict(People) '-> in immediate window shows concatenate Item values
                                        
                Sheet2.Rows(rowsCount).EntireRow.Delete
            Else
                dict.Add People, id
            End If
            
    rowsCount = rowsCount - 1
    
    Loop

End Sub

Answer 2

您可以引用 ID 单元格并在其中连接值，而不是将 ID 值存储在字典中。

Dim idCell As Range, r As Long    
'...
'...
For r = rowCount to 2 Step - 1

    People = Sheet2.Cells(rowCount, "E").Value
    Set idCell = Sheet2.Cells(rowCount, "D")
    
    If dict.Exists(People) Then
        With dict(People) '<< first id cell... 
            .Value = .Value & ";" & IdCell.Value 
        End With
        Sheet2.Rows(rowCount).EntireRow.Delete 'get id *before* delete ;-)
    Else
        dict.Add People, idCell 'reference first ID cell (the cell
                                '  itself, not the cell value)
    End If

 Next r

Answer 3

请看看这是否适合你。

Sub RemDupVal()
        
    Dim t As Range, x As Range, z As Range
        
       Set x = Range("A2:A7") 'ID
       Set z = Range("B2:B7") 'Item
       Set t = Cells(2, Cells(1, 16383).End(xlToLeft).Column + 1).Resize(x.Rows.Count)
        
        t = x.Parent.Evaluate(x.Address & "&" & z.Address) 'assuming evaluate character limit is met
        Union(x, t).Select
        selection.RemoveDuplicates t.Column, xlNo
        t.ClearContents: Cells(1, 1).Select

End Sub