Обїединение ячеек с одинаковыми значениями WORD

[Сергей846]

Ув.форумчане помогите пожалуйста написать макрос, который бы объединял ячейки с одинаковыми значениями в первой колонке, оставляя в объедененой ячейке только одно значение.Таблица оч.больших размеров, значения в первой колонке состоят из счетырех цифр например 1000, 1000, 1502, 1300, 1300, 1300 и т.д. Заранее спасибо.

[viter.alex]

Попробуйте такой вариант. Может он не оптимальный, но он работает:

Sub MergeEqualCells()
  Dim oTbl As Table
  Dim i As Long
  Dim sCellVal As String
  
  If Selection.Information(wdWithInTable) Then
    Set oTbl = Selection.Tables(1)
  Else
    MsgBox "Поставьте курсор внутрь таблицы и запустите макрос вновь!", vbOKOnly + vbInformation, "Объединение ячеек с одинаковыми значениями"
    Exit Sub
  End If
  
  For i = oTbl.Columns(1).Cells.Count To 1 Step -1
    With oTbl.Columns(1).Cells(i)
      .Select
      sCellVal = .Range.Text
    End With
    With Selection
      While .Cells(1).Range.Text = sCellVal And .Cells(1).Range.Start <> oTbl.Range.Cells(1).Range.Start
        .MoveUp Extend:=wdExtend
      Wend
      If .Cells(1).Range.Start <> oTbl.Range.Cells(1).Range.Start Then
        .MoveDown Extend:=wdExtend
      End If
      i = i - .Cells.Count + 1
      If .Cells.Count > 1 Then
        .Cells.Merge
        .Cells(1).Range.Text = Replace(sCellVal, vbCr, "")
      End If
    End With
  Next
End Sub

[Сергей846]

viter.alex
Спасибо большое, все отлично. только почемуто верхние ячейки объединяются с заголовком таблицы, как указать чтобы макрос не перебирал первую строку т.е. шапку таблицы ?

[viter.alex]

Ненужные вам строки я закомментировал (выделено зелёным)

Sub MergeEqualCells()
  Dim oTbl As Table
  Dim i As Long
  Dim sCellVal As String
  
  If Selection.Information(wdWithInTable) Then
    Set oTbl = Selection.Tables(1)
  Else
    MsgBox "Поставьте курсор внутрь таблицы и запустите макрос вновь!", vbOKOnly + vbInformation, "Объединение ячеек с одинаковыми значениями"
    Exit Sub
  End If
  
  For i = oTbl.Columns(1).Cells.Count To 1 Step -1
    With oTbl.Columns(1).Cells(i)
      .Select
      sCellVal = .Range.Text
    End With
    With Selection
      While .Cells(1).Range.Text = sCellVal And .Cells(1).Range.Start <> oTbl.Range.Cells(1).Range.Start
        .MoveUp Extend:=wdExtend
      Wend
      'If .Cells(1).Range.Start <> oTbl.Range.Cells(1).Range.Start Then
        .MoveDown Extend:=wdExtend
      'End If
      i = i - .Cells.Count + 1
      If .Cells.Count > 1 Then
        .Cells.Merge
        .Cells(1).Range.Text = Replace(sCellVal, vbCr, "")
      End If
    End With
  Next
End Sub

[Сергей846]

Все равно объединяет заголовок с ячейками, попробую по колдовать, мож получится.Спасибо.

[viter.alex]

А шапка располагается только в одной строке? Или есть объединённые строки?

[Сергей846]

В одной строке.

[Сергей846]

Как отменить два последних действия макроса, тогда будет все ОК.

[viter.alex]

Отмена двух последних действий:

ActiveDocument.Undo 2

[Николай_В]

1111