Самый быстрый способ объединить дубликаты ячеек без зацикливания Excel

Question

У меня есть ячейки, содержащие повторяющиеся значения, которые я хочу быстро объединить. Таблица выглядит так:

Sub MergeCells()
Application.DisplayAlerts = False
Dim n As Name
Dim fc As FormatCondition
Dim Rng As Range, R As Range
Dim lRow As Long
Dim I&, J&
Dim arr As Variant

ReDim arr(1 To 1) As Variant

With ThisWorkbook.Sheets("tst")
    Set Rng = .Range("A2:D11")
    lRow = Rng.End(xlDown).Row

    For J = 1 To 4
        For I = lRow To 2 Step -1   'last row to 2nd row
            If Trim(UCase(.Cells(I, J))) = Trim(UCase(.Cells(I - 1, J))) Then
                Set R = .Range(.Cells(I, J), .Cells(I - 1, J))
                arr(UBound(arr)) = R.Address
                ReDim Preserve arr(1 To UBound(arr) + 1)
            End If
        Next I
    Next J
    ReDim Preserve arr(1 To UBound(arr) - 1)

    Set R = .Range(Join(arr, ","))
    'MsgBox R.Areas.Count
    'R.Select
    'R.MergeCells = True
    With R
        .Merge
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With

    Stop
End With

Application.DisplayAlerts = True
End Sub

Диапазоны повторяющихся ячеек могут быть несвязанными или несмежными ячейками. Я хочу, чтобы способ быстро идентифицировать такие дубликаты диапазонов и объединить их без использования цикла For. [Не знаю, но думаю, что может быть самый быстрый инновационный способ без циклов, возможно, с использованием некоторой комбинации формул массива Excel и кода VBA для выбора и объединения повторяющихся диапазонов ячеек.]

Кстати, приведенный выше код работает нормально, пока он не выдаст следующую ошибку в строке .Merge.

РЕДАКТИРОВАТЬ Это снимок окна Watch, показывающий содержимое arr, а также R.Address.

ВЫХОД: Не нужно выбирать, это только для демонстрации:

Вывод должен выглядеть так:

РЕДАКТИРОВАТЬ... Предположим, повторяющиеся значения были одинаковыми по строкам? Таким образом, необходимо объединить только дублирующиеся значения столбцов. Должен быть быстрый, инновационный способ сделать это слияние.

Окончательный вывод изображения:

Answer 1

Проблема в том, что ваш код может найти только 2 соседние ячейки и не ищет третью с этим кодом: Set R = .Range(.Cells(I, J), .Cells(I - 1, J))

После первого цикла он добавляет эти 2 ячейки

После очередного цикла добавляются следующие 2 ячейки

И это приводит к перекрытию

который вы можете увидеть на более темном оттенке выделения.

Я только что отредактировал некоторую часть вашего кода с комментариями, чтобы вы могли увидеть, как это можно сделать. Но я уверен, что еще есть место для улучшений.

Sub MergeCellsNew()
    Application.DisplayAlerts = False
    Dim n As Name
    Dim fc As FormatCondition
    Dim Rng As Range, R As Range
    Dim lRow As Long
    Dim I&, J&
    Dim arr As Variant

    ReDim arr(1 To 1) As Variant

    With ThisWorkbook.Sheets("tst")
        Set Rng = .Range("A2:D11")
        lRow = Rng.End(xlDown).Row

        For J = 1 To 4
            I = 2 'I = Rng.Row   to automatically start at the first row of Rng
            Do While I <= lRow
                Set R = .Cells(I, J) 'remember start cell

                'run this loop as long as duplicates found next to the start cell
                Do While Trim(UCase(.Cells(I, J))) = Trim(UCase(.Cells(I + 1, J)))
                    Set R = R.Resize(R.Rows.Count + 1) 'and resize R + 1
                    I = I + 1
                Loop

                'now if R is bigger than one cell there are duplicates we want to add to the arr
                'this way single cells are not added to the arr
                If R.Rows.Count > 1 Then
                    arr(UBound(arr)) = R.Address
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                I = I + 1
            Loop
        Next J
        ReDim Preserve arr(1 To UBound(arr) - 1)

        Set R = .Range(Join(arr, ","))
        With R
            .Merge
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With

        Stop
    End With

    Application.DisplayAlerts = True
End Sub