1

Тема: Объединение ячеек столбца таблицы с одинаковым значением

Доброго времени суток!

Пишу макрос, объединяющий ячейки столбца таблицы с одинаковым значением.
Пока остановился на поиске индексов начала-конца группы таких ячеек.

Мой код:

    ' индексы начала-конца группы одинаковых ячеек
    Dim iStart As Integer
    iStart = 0
    Dim iFinish As Integer
    iFinish = 0
    
    ' флаг объединения ячеек
    Dim bMerge As Boolean    
    bMerge = False
    
    Dim aCell As Word.Cell
    
    Dim cCells As Cells
    ' извлекаем все ячейки столбца
    Set cCells = ActiveDocument.Tables.Item(1).Columns.Item(1).Cells
        
    For Each aCell In cCells
           On Error Resume Next
           
           ' пропускам первую ячейку (начинаем работать со второй)
           If aCell.RowIndex > 1 Then
                ' сравниваем значение с предыдущей
                If aCell.Range.Text = cCells.Item(aCell.RowIndex - 1).Range.Text Then
                        ' при равенстве значений и если нет начала группы iStart = 0, то
                        ' начинаем ее
                        If iStart = 0 Then
                                iStart = aCell.RowIndex - 1
                        End If
                Else
                        ' если значения не равны, то проверяем нужно ли закончить группу
                        If iStart <> 0 Then
                                iFinish = aCell.RowIndex - 1
                                bMerge = True
                        End If
                End If
            End If
            
            ' если достигли конца, завершаем группу
            If iStart <> 0 And aCell.RowIndex = cCells.Count Then
                    iFinish = aCell.RowIndex
                    bMerge = True
            End If
            
            If bMerge Then
              ' объединяем (нужен код)
                                    
              bMerge = False
              MsgBox iStart & " - " & iFinish
              iStart = 0
            End If
            
    Next aCell

Код по определению границ групп ячеек вроде работает, но нужен собственно код объединения ячеек. Заранее спасибо.

2

Re: Объединение ячеек столбца таблицы с одинаковым значением

Объединение одной ячейки с другой:
Cell1.Merge(Cell2)

Объединение всех ячеек в области:
Range.Cells.Merge

Макросы под заказ и готовый пакет - mtdmacro.ru

3

Re: Объединение ячеек столбца таблицы с одинаковым значением

Спасибо, но все не так просто.
Когда мы объединяем ячейки в цикле, то, похоже, после объединения ячеек изменяется количество строк в таблице. Т.е. если мы нашли, что нужно объединить две группы ячеек с 4 по 6 и с 11 по 12, то после объединения ячеек с 4 по 6 индексы 11 и 12 надо уменьшить на 2.
Как написать подобный алгоритм, пока не знаю. Голова идет кругом. Буду рад любой помощи.

4

Re: Объединение ячеек столбца таблицы с одинаковым значением

Кажется, решил задачу. Готов выслушать любые замечания по коду.

    ' индексы начала-конца группы одинаковых ячеек
    Dim iStart As Integer
    iStart = 0
    Dim iFinish As Integer
    iFinish = 0
    
    ' флаг объединения ячеек
    Dim bMerge As Boolean
    bMerge = False
    
    Dim aCell As Word.Cell
    
    Dim cCells As Cells
    ' извлекаем все ячейки столбца
    Set cCells = ActiveDocument.Tables.Item(1).Columns.Item(1).Cells
        
    ' коллекция для сбора индексов объединяемых ячеек
    Dim cCellsForMerge As New Collection
    
    For Each aCell In cCells
           On Error Resume Next
           
           ' пропускам первую ячейку (начинаем работать со второй)
           If aCell.RowIndex > 1 Then
                ' сравниваем значение с предыдущей
                If aCell.Range.Text = cCells.Item(aCell.RowIndex - 1).Range.Text Then
                        ' при равенстве значений и если нет начала группы iStart = 0, то
                        ' начинаем ее
                        If iStart = 0 Then
                                iStart = aCell.RowIndex - 1
                        End If
                Else
                        ' если значения не равны, то проверяем нужно ли закончить группу
                        If iStart <> 0 Then
                                iFinish = aCell.RowIndex - 1
                                bMerge = True
                        End If
                End If
            End If
            
            ' если достигли конца, завершаем группу
            If iStart <> 0 And aCell.RowIndex = cCells.Count Then
                    iFinish = aCell.RowIndex
                    bMerge = True
            End If
            
            If bMerge Then
                    ' сохраняем индексы в коллекцию
                    cCellsForMerge.Add Item:=iStart
                    cCellsForMerge.Add Item:=iFinish
                                    
                    bMerge = False
                    iStart = 0
            End If
            
    Next aCell
    
    ' значение для пересчета индексов ячеек
    Dim iDelim As Integer
    iDelim = 0
    
    ' перебираем коллекцию индексов объединения
    For i = 1 To cCellsForMerge.Count
            ' очищаем все ячейки из группы кроме первой (иначе одинаковое содержимое будет продублировано)
            Call Selection.SetRange(Start:=cCells(cCellsForMerge(i) - iDelim + 1).Range.Start, End:=cCells(cCellsForMerge(i + 1) - iDelim).Range.End)
            Selection.Range.Select
            For Each iCell In Selection.Cells
                    iCell.Range.Text = ""
            Next iCell
            Selection.Collapse
            ' объединяем ячейки
            Call cCells(cCellsForMerge(i) - iDelim).Merge(cCells(cCellsForMerge(i + 1) - iDelim))
            ' вычисляем значение пересчета
            iDelim = iDelim + cCellsForMerge(i + 1) - cCellsForMerge(i)
            ' прыгаем через ячейку (ведь мы анализируем парами)
            i = i + 1
    Next i