VBA merge cells

VBA объединение ячеек

Sub test()
' объединяет ячейки содинаковыми значениями на странице в указанном столбце
Dim RowIndex As Long
Dim StartRow As Long
Dim LastRow As Long
Dim ColumnToMerge As Long
Dim countHPageBreak As Long
Dim hPB As HPageBreak
Dim pageLastRow() As Variant
Dim i As Long, ihPB As Long
Dim flag As Boolean
   
   
    StartRow = 2 ' с какой строки начинать
    ColumnToMerge = 2 ' в какой колонке объединять
    flag = True  ' учитывать ли значения слева False - нет, True - да
    countHPageBreak = ActiveSheet.HPageBreaks.Count
   
    ReDim pageLastRow(countHPageBreak) As Variant
   
    i = 0
    For Each hPB In ActiveSheet.HPageBreaks
     pageLastRow(i) = hPB.Location.Row - 1
     i = i + 1
    Next hPB
    pageLastRow(countHPageBreak) = Cells(Rows.Count, ColumnToMerge).End(xlUp).Row
   
   
   
    Application.DisplayAlerts = False
    For ihPB = 0 To countHPageBreak
       
        For RowIndex = StartRow + 1 To pageLastRow(ihPB)
           
            With Cells(RowIndex, ColumnToMerge)
               
                If .Value = .Offset(-1, 0).MergeArea.Cells(1).Value Then
                  If flag Then
                     If .Offset(0, -1).MergeArea(1).Value = .Offset(-1, -1).MergeArea(1).Value Then  '.Offset(0, -1).MergeArea.Address <> .Offset(-1, -1).MergeArea.Address Then
                         Range(Cells(RowIndex, ColumnToMerge), .Offset(-1, 0)).Merge
                     End If
                   Else
                  Range(Cells(RowIndex, ColumnToMerge), .Offset(-1, 0)).Merge
                  End If
                End If
         
            End With
           
           
        Next RowIndex
       
        StartRow = pageLastRow(ihPB) + 1
    Next ihPB
    Application.DisplayAlerts = True
End Sub