Макрос для получения диапазонов для каждого уникального значения в столбце

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 диапазона: Диапазон («A1: B1»), Диапазон («A9: B9») и Диапазон («A13: B13»)

• Для 109 есть 2 диапазона: Range ("A6: B8") и Range ("A11: B12")

Моя последняя цель - присоединиться кодин диапазон, использующий Union(), чтобы закрасить разными цветами строки, связанные с каждым уникальным значением, но я не хочу использовать метод автофильтра, поскольку он медленный.

Возможно, кто-то может помочь с этим.Заранее спасибо

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