宏以获取列中每个唯一值的范围

Posted 2021-03-27

我有以下代码显示B列中的唯一值以及每个值出现的行号。它有效，但我的最终目标是打印每个唯一值出现的范围。

Sub GetRanges()

Set aw = Application.WorksheetFunction
LastRow = ActiveSheet.UsedRange.Rows.Count
arr = Application.Transpose(Range("B1:B" & LastRow).Value)

    Set d = CreateObject("Scripting.Dictionary")

    For i = LBound(arr) To UBound(arr)
            d(arr(i)) = d(arr(i)) & "," & i
    Next i

For Each Key In d.Keys
    Debug.Print Key, Mid(d(Key), 2)
Next Key

End Sub

来自A1：B19的输入数据是：

    A           B
1   BLOCK ABC    
2   Code        Number
3   RRU         91
4   OCJS        103
5   IE          43
6   UHDI        109
7   IJCD        109
8   EIE         109
9   BLOCK DEF    
10  Code        Number
11  UUTY        109
12  EER         109
13  BLOCK GHI    
14  Code        Number
15  RUO         223
16  YUH         223
17  JKKPW       223
18  OOOI        223
19  JSDDF       82

显示B列中每个唯一值的行的当前输出是：

Value     |  Rows 
--------------------------
          |  1,9,13
Number    |  2,10,14
91        |  3
103       |  4
43        |  5
109       |  6,7,8,11,12
223       |  15,16,17,18
82        |  19

我想获得每个唯一值的范围，如下所示：

Value    |    Range 
--------------------------
         |    1,9,13
Number   |    2,10,14
91       |    3
103      |    4
43       |    5
109      |    6-8,11-12
223      |    15-18
82       |    19
         |

这意味着

• 对于empty值，有3个范围，范围（“A1：B1”），范围（“A9：B9”）和范围（“A13：B13”）
• 对于109，有2个范围，范围（“A6：B8”）和范围（“A11：B12”）

我的最终目标是使用Union()加入单个Range，使用不同的颜色着色与每个唯一值相关的行，但我不想使用Autofilter方法，因为它很慢。

也许有人可以帮忙解决这个问题提前致谢

答案

如果将行号更改为范围，则执行一些文本处理，Union可以将行号分组在一起。

Option Explicit

Sub GetRanges()

    Dim str As String, d As Object, lr As Long, arr As Variant, i As Long, key As Variant

    lr = ActiveSheet.UsedRange.Rows.Count
    arr = Application.Transpose(Range("B1:B" & lr).Value)

    Set d = CreateObject("Scripting.Dictionary")

    For i = LBound(arr) To UBound(arr)
        'collect items as range references
        d(arr(i)) = d(arr(i)) & ",Z" & i
    Next i


    'process row numbers as range
    For Each key In d.Keys
        'collect key's item
        str = Mid(d(key), 2)
        'union the range address back to str
        str = Union(Range(str), Range(str)).Address(0, 0)
        'remove column and swap colons for hyphens
        str = Replace(Replace(str, "Z", vbNullString), ":", "-")
        'replace key's item with processed str
        d(key) = str
    Next key

    For Each key In d.Keys
        Debug.Print key, d(key)
    Next key

End Sub