從 D 列中提取唯一值並組合在一個單元格中。 Excel VBA

Question

我在 (D) 列中有重復的值。

如何使用 vba 從 D 列中提取唯一值並在單個單元格 (H1) 中組合而不丟失數據

例如：“J10P、G345、R1、J10G”

Answer 1

連接唯一值（字典）

• 調整常量部分和工作簿中的值。

Option Explicit

Sub concatUnique()
    
    Const sName As String = "Sheet1"
    Const sFirst As String = "D1"
    
    Const dName As String = "Sheet1"
    Const dFirst As String = "H1"
    Const dDelim As String = ", "

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Create a reference to the Source Range.
    Dim srg As Range
    Dim srCount As Long
    With wb.Worksheets(sName).Range(sFirst)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Sub
        srCount = lCell.Row - .Row + 1
        Set srg = .Resize(srCount)
    End With

    ' Write values from Source Range to Source Data Array.
    Dim sData As Variant
    If srCount = 1 Then
        ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
    Else
        sData = srg.Value
    End If
    
    ' Write unique values from Source Data Array to Unique Dictionary.
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    Dim Key As Variant
    Dim r As Long
    For r = 1 To UBound(sData, 1)
        Key = sData(r, 1)
        If Not IsError(Key) Then
            If Len(Key) > 0 Then
                dict(Key) = Empty
            End If
        End If
    Next r
    
    If dict.Count > 0 Then
        ' Create a reference to the Destination Cell (Range).
        Dim dCell As Range: Set dCell = wb.Worksheets(dName).Range(dFirst)
        ' Write the unique values from Unique Dictionary to Resulting String.
        Dim Result As String: Result = Join(dict.Keys, dDelim)
        ' Write the result to the Destination Cell (Range).
        dCell.Value = Result
        ' or in one line:
        'wb.Worksheets(dName).Range(dFirst).Value = Join(dict.Keys, dDelim)
    End If
    
End Sub