从范围创建不同的列表

Question

我有一系列从D2到BK33的值，我想从这个范围创建一个不同值的列表。是否有一个函数可以创建这样的列表？

Answer 1

输入这两个宏并运行sub TESTU：

Sub ExtractUniques(rIn As Range, rOut As Range)
    Dim C As Collection, r As Range
    Set C = New Collection
    Dim cC As Long
    On Error Resume Next
    For Each r In rIn
        If r.Value <> "" Then
            C.Add r.Value, CStr(r.Value)
        End If
    Next r
    cC = C.Count
    I = 1
    For Each r In rOut
        r.Value = C.Item(I)
        I = I + 1
        If I > cC Then Exit Sub
    Next r
End Sub


Sub TESTU()
    Dim r1 As Range, r2 As Range
    Set r1 = Range("D2:BK33")
    Set r2 = Range("BN2:BN70")
    Call ExtractUniques(r1, r2)
End Sub

注意：

1. 转移前不会清除目的地范围

2. 如果目标范围中的空间值多于空格，则会填充目标范围，并丢弃额外的不同值。

修改＃1

为了满足数据更改时运行流程的要求，

首先丢弃子 TESTU

第二次修改子 ExtractUniques 以使其成为公共：

Public Sub ExtractUniques(rIn As Range, rOut As Range)
    Dim C As Collection, r As Range
    Set C = New Collection
    Dim cC As Long
    On Error Resume Next
    For Each r In rIn
        If r.Value <> "" Then
            C.Add r.Value, CStr(r.Value)
        End If
    Next r
    cC = C.Count
    I = 1
    For Each r In rOut
        r.Value = C.Item(I)
        I = I + 1
        If I > cC Then Exit Sub
    Next r
End Sub

首先在工作表代码区域中放置以下事件宏：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r1 As Range, r2 As Range
    Set r1 = Range("D2:BK33")
    Set r2 = Range("BN2:BN70")
    If Intersect(r1, Target) Is Nothing Then Exit Sub
    r2.ClearContents
    Call ExtractUniques(r1, r2)
End Sub