附加唯一值

用法

Sub AppendUniqueTest()
    
    Dim Arr() As Variant: Arr = Array(1, 2, 3, 4, 5)
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
    
    AppendUnique Arr, ws, "A1"

End Sub

"方法"

Sub AppendUnique( _
        Arr() As Variant, _
        ByVal ws As Worksheet, _
        ByVal FirstCellAddress As String, _
        Optional ByVal OverWrite As Boolean = False)
   
    ' Write the data from the source range to the source array ('sData').
    ' Reference the first destination cell ('fCell').

    If ws.FilterMode Then ws.ShowAllData
    
    Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)
    
    Dim sData() As Variant, srCount As Long
    
    With fCell
        Dim lCell As Range: Set lCell = .Resize(ws.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If Not lCell Is Nothing Then
            srCount = lCell.Row - .Row + 1
            If srCount = 1 Then
                ReDim sData(1 To 1, 1 To 1): sData(1, 1) = .Value
            Else
                sData = .Resize(srCount).Value
            End If
            If Not OverWrite Then Set fCell = lCell.Offset(1)
        End If
    End With
            
    ' Write the unique data from the source array to a dictionary.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim sr As Long
    
    For sr = 1 To srCount: dict(CStr(sData(sr, 1))) = Empty: Next sr
    
    Erase sData
    
    ' Define the destination array ('dData').
    
    Dim lb As Long: lb = LBound(Arr)
    Dim ub As Long: ub = UBound(Arr)
    
    Dim dData() As Variant: ReDim dData(1 To ub - lb + 1, 1 To 1)
                 
    ' Check the values from the given array ('Arr') against the values
    ' in the dictionary and write the non-matches to the destination array.
    
    Dim dr As Long, c As Long, cString As String
                 
    For c = lb To ub
        cString = CStr(Arr(c))
        If Len(cString) > 0 Then ' is not blank
            If Not dict.Exists(cString) Then ' is not in the dictionary
                dict(cString) = Empty ' prevent dupes from the given array
                dr = dr + 1
                dData(dr, 1) = cString
            End If
        End If
    Next c
    
    If dr = 0 Then
        MsgBox "No new values found.", vbExclamation
        Exit Sub
    End If
    
    ' Write the values from the destination array to the destination range.
    
    fCell.Resize(dr).Value = dData
    If OverWrite Then ' clear below
        fCell.Resize(ws.Rows.Count - fCell.Row - dr + 1).Offset(dr).Clear
    End If
        
    ' Inform.
        
    MsgBox "Data appended.", vbInformation
         
End Sub