excel - 用于获取列中每个唯一值的范围的宏

Question

我有以下代码，显示 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
         |

这意味着

• 对于空值，有3个范围，Range("A1:B1")、Range("A9:B9")和Range("A13:B13")

• 对于 109 有 2 个范围，Range("A6:B8") 和 Range("A11:B12")

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

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

Answer 1

如果您将行号更改为执行一些文本处理的范围，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