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
         |

这意味着

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

我的最终目标是使用Union()加入单个Range中，使与每个唯一值相关的行以不同的颜色着色，但是我不想使用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

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

1 个答案: