evgeniygeo, Вот вариант по максимальному количеству строк в диапазоне.
Для наглядности вставил MsgBox который показывает собранные диапазоны, после того как Вам станет ясно, что и как удалите чтобы не мешал.
Далее их разбивает анализируем и с наибольшим количеством строк объединяем, остальные красим в красный. Если будут два диапазона с одинаковым количеством, по объединит оба. Для понимания как записаны диапазоны я их разграничил. Попробуйте на двух вариантах, чтобы понять разницу.
Если нужно другой принцип выбора диапазона, переделаете как нужно Вам, то пример анализа Вам показал в этом коде,
Код |
---|
Sub Макрос1()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim r As Long, c As Long, arr As Variant, n As Variant, mx As Variant
arr = Range("A4:D11")
Set Dict = CreateObject("Scripting.Dictionary")
For c = 1 To UBound(arr, 2)
For r = 1 To UBound(arr)
If Not Dict.Exists(arr(r, c)) Then
Dict.Add arr(r, c), Cells(r + 3, c).Address
Else
Dict.Item(arr(r, c)) = Union(Range(Dict.Item(arr(r, c))), Cells(r + 3, c)).Address
End If
Next r
Next c
For Each n In Dict
'Для наглядности вставил MsgBox который показывает собранные диапазоны.
'Далее их разбивает анализируем и с наибольшим количеством строк объединяем, остальные красим в красный
MsgBox Dict.Item(n)
If Not n = "" Then
mx = 0
arr1 = Split(Dict.Item(n), ",")
For Each m In arr1
If mx < Range(m).Rows.Count Then mx = Range(m).Rows.Count
Next m
For Each m In arr1
If Range(m).Rows.Count = mx Then Range(m).Merge Else Range(m).Interior.Color = vbRed
Next m
End If
Next n
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
|