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
      .MoveDown Extend:=wdExtend
      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

Private Sub Кнопка0_Click()
   
Dim app As Word.Application  'Приложение программы
Dim strDOC As String ' Имя документа
Dim strDOT As String ' Имя шаблона
Dim strMDB As String ' Имя базы данных
Dim rng As Word.Range ' Область данных
Dim tbl As Word.Table ' Таблица документа
Dim c As Word.Cell ' Ячейка таблицы
Dim i As Long ' Переменная
Dim j&
Dim dbs As Database, sSQL As String
Dim funCreateQueries As String
Dim qdf As QueryDef
Dim oTbl As Table
Dim sCellVal As String
On Error GoTo  999 
    Screen.MousePointer =  11 
    
  
    ' Определяем имена шаблона, документа и базы данных
    With Application.CurrentProject
        strDOT = .Path & "\" & "\Shablons\04.dot"
        strDOC = .Path & "\" & "\Отчеты\Ведомость №4.doc"
        strMDB = .Path & "\" & .Name
    End With
    
    ' Управление документом Word
    Set app = New Word.Application 'Новое приложение Word
    app.Documents.Add strDOT 'Добавляем шаблон
    ' Выбираем закладку (позицию) таблицы
    Set rng = app.ActiveDocument.Bookmarks("Таблица").Range
    
    DoCmd.DeleteObject acQuery, "qr1"
    Set dbs = CurrentDb
    With dbs
  sSQL = "SELECT qr_UnProf.R020 AS sh, qr_UnProf.OB22 AS ss, qr_UnProf.txt AS n, Format([qr_UnProf]![q1]+[qr_UnProf]![q2]+[qr_UnProf]![q3],""##,##0.00"") AS 1kv, Format([qr_UnProf]![q4],""##,##0.00"") AS s1, Format([qr_UnProf]![q1]+[qr_UnProf]![q2]+[qr_UnProf]![q3]+[qr_UnProf]![q4],""##,##0.00"") AS [S1+2]FROM qr_UnProf"
Set qdf = CurrentDb.CreateQueryDef("qr_word ", sSQL)
    End With
    funCreateQueries = True
        
        'заранее созданная таблица в виде строки заголовков колонок запроса (+Nпп)
        Set tbl = rng.Tables(rng.Tables.count)
        'открыть запрос, перегнать построчно данные в таблицу документа
        Dim db As DAO.Database: Set db = CurrentDb()
        Dim ds As DAO.Recordset: Set ds = db.OpenRecordset("qr1", dbOpenSnapshot)
        Do While Not ds.EOF
            tbl.Rows.Add: i = i +  1  'добавить строку
               For j =  1  To ds.Fields.count
                tbl.Rows(tbl.Rows.count).Cells(j +  0 ).Range.InsertAfter CStr(ds.Fields(j -  1 ).Value)
            Next j
            ds.MoveNext
        Loop
        tbl.AutoFormat wdTableFormatGrid8 ' авто-формат
        tbl.Columns( 1 ).Width =  50  'ПРИМЕР изменения ширины столбца
        ' Форматируем заголовок, т.е. всю строку
    tbl.Columns( 1 ).Select ' вібраем колонку
    With app.Selection
        .Font.Name = "Times New Roman"
        .Font.bOld = True
        .Font.Italic = False
    End With
    tbl.Columns( 3 ).Select ' вібраем колонку
    With app.Selection
    .ParagraphFormat.Alignment = wdAlignParagraphJustify
    End With
    tbl.Rows( 1 ).Select ' Выбираем заголовок
    With app.Selection
        .ParagraphFormat.Alignment = wdAlignParagraphCenter
        .Font.Name = "Times New Roman" ' Имя шрифта
        .Font.Size =  11  ' Размер шрифта
    End With
[color=red]      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
      .MoveDown Extend:=wdExtend
      i = i - .Cells.Count +  1 
      If .Cells.Count >  1  Then
        .Cells.Merge
        .Cells( 1 ).Range.Text = Replace(sCellVal, vbCr, "")
      End If
    End With
  Next[/color]
    app.ActiveDocument.SaveAs strDOC  ' Сохраняем файл
    app.Visible = True 'Отображаем документ
    Screen.MousePointer =  0 
    Exit Sub

 999 :
    Screen.MousePointer =  0 
    MsgBox Err.Description,  48  'Ошибка
    Err.Clear
    app.Quit

End Sub