Цикл для объединения

[Trimbl]

Здравствуйте уважаемые!
Для объединения ячеек в двух столбцах применяю вот такой макрос:

Option Explicit

Sub MergeCells() ' Макрос объединения
  Dim r As Long, rc As Long
  r = 17
  Do While Not IsEmpty(Range("B17:C17"))
    rc = WorksheetFunction.CountIfs(Columns(2), Cells(r, 2), Columns(3), Cells(r, 3))
    'rc = WorksheetFunction.CountIfs(Columns(2), "<> ", Columns(3), "<> ")
    Application.DisplayAlerts = False
    If rc > 1 Then Cells(r, 2).Resize(rc, 1).MergeCells = True: Cells(r, 3).Resize(rc, 1).MergeCells = True
    Application.DisplayAlerts = True
    r = r + rc
Loop
End Sub

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

[IgorGO]

Sub MergeCells() 
  Dim r2 As Long, rc2 As Long, r3 As Long, rc3 As Long
  r2 = 17
  Do While Not IsEmpty(Cells(r2, 2))
    rc2 = WorksheetFunction.CountIf(Columns(2), Cells(r2, 2))
    Application.DisplayAlerts = False
    If rc2 > 1 Then Cells(r2, 2).Resize(rc2, 1).MergeCells = True
    r3 = r2
    Do While r3 < r2 + rc2
      rc3 = WorksheetFunction.CountIf(Columns(3), Cells(r3, 3))
      If rc3 > 1 Then Cells(r3, 3).Resize(rc3, 1).MergeCells = True
      r3 = r3 + rc3
    Loop
    Application.DisplayAlerts = True
    r2 = r2 + rc2
  Loop
End Sub

Объединяет не корректно

если есть техника разных типов одного производителя - будет работать неправильно! (в колонке С такого наобьединяет!!!) если данные не отсортированы - будет ВСЕ не правильно обьеденено

да еще и зависает(зацикливается)

как написано - так и работает

Может быть подскажите - чего ему не хватает

программиста

[Trimbl]

Про программиста я знал изначально, но благо, что существует такой форум и в частности такие отзывчивые люди как Вы Игорь.
Спасибо.

[Trimbl]

IgorGO, опять без программиста - и ни туды и ни сюды. Не могу допетрить как в Ваш код воткнуть условие когда rc2=WorksheetFunction.CountIf(Colum ns(2), Cells(r2, 2))=1 (и аналогично rc3=1), а такое оказывается случается и тогда цикл обрывается. т.е вопрос - как организовать проверку If rc2 <> 1 и соответственно If rc3 <> 1, или это не возможно(недопустимо)? Кажется пересмотрел все, но ничего подобного не увидел или не нашел.

[IgorGO]

не совсем понимаю о чем речь, но...
сортируете данные по колонке 2 потом по 3
используете этот

Sub MergeCells()
  Dim r2 As Long, rc2 As Long, r3 As Long, rc3 As Long
  r2 = 17
  Do While Not IsEmpty(Cells(r2, 2))
    rc2 = WorksheetFunction.CountIf(Columns(2), Cells(r2, 2))
    Application.DisplayAlerts = False
    If rc2 > 1 Then Cells(r2, 2).Resize(rc2, 1).MergeCells = True
    r3 = r2
    Do While r3 < r2 + rc2
      rc3 = WorksheetFunction.CountIf(Range(r2, 3).Resize(rc2, 1), Cells(r3, 3))
      If rc3 > 1 Then Cells(r3, 3).Resize(rc3, 1).MergeCells = True
      r3 = r3 + rc3
    Loop
    Application.DisplayAlerts = True
    r2 = r2 + rc2
  Loop
End Sub

без каких-либо ограничений

[Trimbl]

Иногда отсортированная колона имеет примерно такой вид:
Экскаватор
Экскаватор
Экскаватор
Бульдозер
Погрузчик
Погрузчик
Погрузчик

т.е когда в колонке встречается всего одна одноименная ячейка, в нашем случае - Бульдозер, вот на нем(Бульдозере) код и спотыкается. Как проскочить эту одну ячейку, где и объединять-то нечего.
И еще объясните пожалуйста предусловие -Do While r3 < r2 + rc2, в моем понимании r3 всегда будет меньше r2 + rc2

[IgorGO]

ладно, а такой

Sub MergeCells()
  Dim r2 As Long, rc2 As Long, r3 As Long, rc3 As Long
  r2 = 17
  Do While Not IsEmpty(Cells(r2, 2))
    rc2 = WorksheetFunction.CountIf(Columns(2), Cells(r2, 2))
    Application.DisplayAlerts = False
    If rc2 > 1 Then
      Cells(r2, 2).Resize(rc2, 1).MergeCells = True
      r3 = r2
      Do While r3 < r2 + rc2
        rc3 = WorksheetFunction.CountIf(Cells(r2, 3).Resize(rc2, 1), Cells(r3, 3))
        If rc3 > 1 Then Cells(r3, 3).Resize(rc3, 1).MergeCells = True
        r3 = r3 + rc3
      Loop
    End If
    Application.DisplayAlerts = True
    r2 = r2 + rc2
  Loop
End Sub

работал бы и предыдущий только вместо

rc3 = WorksheetFunction.CountIf(Range(r2, 3).Resize(rc2, 1), Cells(r3, 3))
написать
rc3 = WorksheetFunction.CountIf(Cells(r2, 3).Resize(rc2, 1), Cells(r3, 3))

я опечатку сделал(((

[Trimbl]

Благодарю.
С -Do While r3 < r2 + rc2 разобрался, - по горячке сам зациклися