'Sub m1()
'   Call MergeBySameCells_byPages("1 2", 0, 0, 0, 0)
'End Sub
                
'Макрос MergeBySameCells_byPages
'Описание:
'Вызывает макрос MergeBySameCells на каждой из укзанных страниц
'Входные параметры:
'Pages - строка с номерами страниц(по порядку) через пробел
'Обрабатываемый диапазон для MergeBySameCells
Sub MergeBySameCells_byPages(Pages As String, ByVal Xbeg As Integer, ByVal Ybeg As Integer, ByVal cntCol As Integer, ByVal cntRow As Integer)
    Dim PageArray() As String
    Dim arrCnt As Integer
    Dim i As Integer
	
	'Из-за особенности, что на клиенте, вместо параметра который прописан как строка, напрмер "2" сюда передается ""2""
	Pages = Replace(Pages, Chr(34), "")
    If Pages = "" Then
		'Вызываем MergeBySameCells на всех имеющихся страницах
        For sheet1 = 1 To Sheets.Count            
            Worksheets(sheet1).Activate
			Call MergeBySameCells(Xbeg, Ybeg, cntCol, cntRow)
        Next sheet1
        Worksheets(1).Activate
    Else
        PageArray = Split(Pages, " ")
        arrCnt = UBound(PageArray)
                        
        'Вызываем MergeBySameCells на указанной странице
        For sheet1 = 1 To Sheets.Count
            For i = 0 To arrCnt
                If Worksheets(sheet1).Index = CInt(PageArray(i)) Then
                    Worksheets(sheet1).Activate
                    Call MergeBySameCells(Xbeg, Ybeg, cntCol, cntRow)
                    Exit For
                End If
            Next i
        Next sheet1
        Worksheets(1).Activate
    End If
End Sub
                
                
'Макрос MergeBySameCells
'Описание:
'Пробегается по строкам диапазона и объединяет рядом стоящие непустые ячейки с одинаковыми значениями.
'При объединении устанавливается правильная высота строки.
'Входные параметры:
'Обрабатываемый диапазон:
'Xbeg - номер колонки крайней левой ячейки
'Ybeg - номер строки крайней левой ячейки
'cntCol - количество колонок вправо
'cntRow - количество строк вниз
'Если переданы координаты все 0, то границы диапазона определяются по тексту в ячейках: 
'Top_MergeBySameCells - в верхней по диагонали колонке, от начала диапозона
'endCol_MergeBySameCells - в конечной колонке диапозона + 1 
'endRow_MergeBySameCells - в конечной строке диапозона + 1
'Примеры выхова:
'Call MergeBySameCells(0, 0, 0, 0)
'Call MergeBySameCells(2, 6, 100, 5)
Sub MergeBySameCells(ByVal Xbeg As Integer, ByVal Ybeg As Integer, ByVal cntCol As Integer, ByVal cntRow As Integer)
    Dim testVal As String
    Dim range1 As Range
    Dim cell1, cell2 As Range
    Dim r, i, begIdx, endIdx, endlastIndex As Integer
    Dim XEnd, YEnd As Integer
    Dim maxRowHeight As Single
    Dim fRange As Range
    Dim fCol, fRow As Integer
    fCol = 0
    fRow = 0
                                            
    '=====================================================================================
    'Ищем диапозон для обработки, если он не совсем задан
    '======================================================================================
    'Входные параметры для тестирования
    'Dim Xbeg As Integer, Ybeg As Integer, cntCol As Integer, cntRow As Integer
    '
    'Xbeg = 2
    'Ybeg = 6
    'cntCol = 247
    'cntRow = 4
                                        
    If (Xbeg = 0 And Ybeg = 0) Then
        'Ищем конечную колонку по тексту "Top_MergeBySameCells"
        Set fRange = ActiveSheet.Cells.Find(What:="Top_MergeBySameCells", After:=Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
                                        
        If Not fRange Is Nothing Then
            'Берём случай, когда это верхняя ячейка от диапозона, который размножается по строкам и столбцам
            'Поэтому прибаляем к ней 1 строку и 1 колонку
            If fRange.MergeCells = True Then
                Xbeg = fRange.MergeArea.Cells.Column + fRange.MergeArea.Cells.Columns.Count
                Ybeg = fRange.MergeArea.Cells.Row + fRange.MergeArea.Cells.Rows.Count
            Else
                Xbeg = fRange.Cells.Column + 1
                Ybeg = fRange.Cells.Row + 1
            End If
                            
            'fRange.Value = ""
            fRange.Replace What:="Top_MergeBySameCells", Replacement:="", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
		Else
			Xbeg=1
			Ybeg=1
        End If		
    End If
                                                    
    If (cntCol = 0) Then
        'Ищем конечную колонку по тексту "endCol_MergeBySameCells"
        Set fRange = ActiveSheet.Cells.Find(What:="endCol_MergeBySameCells", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
                                        
        If Not fRange Is Nothing Then
            fCol = fRange.Column - 1
                            
            'fRange.Value = ""
            fRange.Replace What:="endCol_MergeBySameCells", Replacement:="", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        End If
    End If
                                                                    
    If (cntRow = 0) Then
        'Ищем конечную строку по тексту "endRow_MergeBySameCells"
        Set fRange = ActiveSheet.Cells.Find(What:="endRow_MergeBySameCells", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
                                                                    
        If Not fRange Is Nothing Then
            fRow = fRange.Row - 1
                            
            'fRange.Value = ""
            fRange.Replace What:="endRow_MergeBySameCells", Replacement:="", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        End If
    End If
                                        
    'Индекс крайней правой колнки
    If cntCol <> 0 Then
        XEnd = Xbeg + cntCol - 1
    Else
        XEnd = fCol
    End If
    'Индекс нижней строки
    If cntRow <> 0 Then
        YEnd = Ybeg + cntRow - 1
    Else
        YEnd = fRow
    End If
    '===============================================================================
                                                        
    r = Ybeg
    'Отключаем обновление экрана
    Application.ScreenUpdating = False
    '-------------------------------
    'Цикл по строкам
    '-------------------------------
    Do While r <= YEnd
                                                        
        'Индекс начальной колонки
        begIdx = Xbeg
        i = Xbeg
        maxRowHeight = Range(Cells(r, i), Cells(r, i)).RowHeight
                                                            
        '-------------------------------
        'Цикл по колонкам
        '-------------------------------
        Do While i <= XEnd
            'Начальная ячейка в строке
            Set cell1 = Cells(r, begIdx)
            'Значение для сравнения
            testVal = Cells(r, begIdx).Value
                                                                
            'Индекс колонки  конечной ячейки
            If cell1.MergeCells = True Then
                endIdx = begIdx + Cells(r, begIdx).MergeArea.Cells.Columns.Count
            Else
                endIdx = begIdx + 1
            End If
            If endIdx > XEnd Then
                Exit Do
            End If
            'Конечная ячейка
            Set cell2 = Cells(r, endIdx)
                                                                
            'Только непустые ячейки
            If testVal <> "" And testVal <> "1" Then
                Do While 1 > 0
                    If testVal = Cells(r, endIdx).Value Then
                        'индекc конечной совпашей ячейки
                        endlastIndex = endIdx
                        Cells(r, endlastIndex).Value = ""
                                                                                                    
                        'Индекс  новой конечной ячейки
                        If cell1.MergeCells = True Then
                            endIdx = endIdx + ActiveCell.MergeArea.Cells.Columns.Count
                        Else
                            endIdx = endIdx + 1
                        End If
                        i = endIdx
                        'Новая Конечная ячейка
                        Set cell2 = Cells(r, endIdx)
                                                                                                
                        'не выходим из диапозона
                        If endIdx > XEnd Then
                            'Автоподбор высоты
                            Set range1 = Range(Cells(r, begIdx), Cells(r, endlastIndex))
                            endlastIndex = Emty
                                                                    
                            range1.HorizontalAlignment = xlCenterAcrossSelection ' по центру выделения
                            range1.VerticalAlignment = xlTop
                            range1.WrapText = True 'переносить по словам
                            range1.EntireRow.AutoFit 'автовыравнивание
                            If (range1.RowHeight > maxRowHeight) Then
                                maxRowHeight = range1.RowHeight
                            End If
                                                                                
                            'Объединение
                            range1.Merge
                            Exit Do
                        End If
                    Else
                        'Одна ячейка - её все равнонадо выравнять
                        If (endIdx - begIdx) = 1 Then
                            'Автоподбор высоты
                            Set range1 = Range(Cells(r, begIdx), Cells(r, begIdx))
                            range1.HorizontalAlignment = xlCenterAcrossSelection ' по центру выделения
                            range1.WrapText = True 'переносить по словам
                            range1.VerticalAlignment = xlTop
                            range1.EntireRow.AutoFit 'автовыравнивание
                            If (range1.RowHeight > maxRowHeight) Then
                                maxRowHeight = range1.RowHeight
                            End If
                        End If
                                                                            
                        If endlastIndex <> Empty And begIdx < endlastIndex Then
                             'Автоподбор высоты
                            Set range1 = Range(Cells(r, begIdx), Cells(r, endlastIndex))
                            endlastIndex = Emty
                                                                    
                            range1.HorizontalAlignment = xlCenterAcrossSelection ' по центру выделения
                            range1.WrapText = True 'переносить по словам
                            range1.VerticalAlignment = xlTop
                            range1.EntireRow.AutoFit 'автовыравнивание
                            If (range1.RowHeight > maxRowHeight) Then
                                maxRowHeight = range1.RowHeight
                            End If
                                                                                
                            'Объединение по последней совпашей ячейке
                            range1.Merge
                            'Заливка цветом
                            'Range(Cells(r, begIdx), Cells(r, endlastIndex)).Interior.Color = vbGreen
                        End If
                                                                                                
                       'Новая начальная ячейка
                        begIdx = endIdx
                        i = endIdx
                        Exit Do
                    End If
                Loop
            Else
                begIdx = endIdx
                i = endIdx
            End If
                                                                
        Loop
        'Автоподбор высоты
        '409.5  - макс высота строки в экселе
        If maxRowHeight <= 409.5 Then
            Range(Cells(r, 1), Cells(r, 1)).RowHeight = maxRowHeight
        Else
            Range(Cells(r, 1), Cells(r, 1)).RowHeight = 409.5
        End If
                                                            
        r = r + 1
    Loop
                                                    
    Application.ScreenUpdating = True
End Sub
