Sub m()
      Dim i As Integer, n As Integer
      n = 16
      Application.DisplayAlerts = False
      While Cells(16 + i, 16) <> ""
         If Cells(16 + i, 1) = Cells(17 + i, 1) Then
            Range(Cells(n, 1), Cells(17 + i, 1)).Select
            If Cells(17 + i, 1) <> Cells(18 + i, 1) Then
               Range(Cells(n, 1), Cells(17 + i, 1)).Merge      
            End If                        
         Else
            n = 17 + i
         End If
         i = i + 1
      Wend
      Application.DisplayAlerts = True
End Sub

Sub Мяу()
         Application.DisplayAlerts = False
             Range(Cells(16, "p"), Cells(16, "P").End(xlDown)).Offset(, -15).Merge
         Application.DisplayAlerts = True
End Sub

Sub Merge_Similar_in_Columns()   ' группировать ячейки с одинаковыми значениями, идущие в столбцах подряд
    If TypeName(Selection) <> "Range" Then Exit Sub
    If Selection.Cells.Count <= 1 Then Exit Sub
    Dim rColumn As Range, rCell As Range, sAddress$, rMerge As Range, rTarget As Range
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    Set rTarget = Intersect(Selection, ActiveSheet.UsedRange)
    For Each rCell In rTarget      ' разгруппировать с заполнением значениями (на всякий случай)
       If rCell.MergeCells Then
          sAddress = rCell.MergeArea.Address: rCell.UnMerge   ' разгруппировать
          Range(sAddress).Value = rCell.Value   ' заполнить
       End If
    Next
    rTarget.Select
    'Stop
    For Each rColumn In rTarget.Columns
       For Each rCell In rColumn.Cells   ' группировать ячейки с одинаковыми значениями
          If rMerge Is Nothing Then
             Set rMerge = rCell
          Else
             If rMerge(1).Value = rCell.Value Then
                Set rMerge = Union(rMerge, rCell): rMerge.Merge
             Else
                Set rMerge = rCell
             End If
          End If
       Next
       Set rMerge = Nothing
    Next
    Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub

Sub UnMerge_and_Fill_by_Value()   ' разгруппировать все ячейки в Selection и ячейки каждой бывшей группы заполнить значениями из их первых ячеек
    If TypeName(Selection) <> "Range" Then Exit Sub
    If Selection.Cells.Count <= 1 Then Exit Sub
    Dim rCell As Range, sAddress$   ', i&, sValue$
    Application.ScreenUpdating = False
    For Each rCell In Intersect(Selection, ActiveSheet.UsedRange).Cells
       If rCell.MergeCells Then
          sAddress = rCell.MergeArea.Address: rCell.UnMerge
          Range(sAddress).Value = rCell.Value
       End If
    Next
    Application.ScreenUpdating = True
End Sub