Разбить ячейку таблицы поабзацно...

RIKITIKI

Топикстартер
15 лет на форуме
Сообщения
1 252
Оценка реакций
401
Добрый день!
Имеется таблица. В некоторых строках которой не один абзац, а скажем четыре. То есть в каждой ячейке такой строки по четыре абзаца. Есть ли какой-то макрос для разбивки таких строк поабзацно?222.jpg
 

Linxy

Девушка с битой
10 лет на форуме
Сообщения
2 273
Оценка реакций
3 840

RIKITIKI

Топикстартер
15 лет на форуме
Сообщения
1 252
Оценка реакций
401
Да, я пользуюсь... только утомительно в каждой ячейке запускать....
Хотелось найти решение в Ворде и для всего файла сразу :(
 

Linxy

Девушка с битой
10 лет на форуме
Сообщения
2 273
Оценка реакций
3 840
Вот тут товарищи похожий макрос сочинили
 

Gad

Участник
Сообщения
999
Оценка реакций
490
Последнее редактирование:

Gad

Участник
Сообщения
999
Оценка реакций
490
Хотелось найти решение в Ворде и для всего файла сразу
С подачи @Linxy
Код:
Sub ParagraphRow()
Application.ScreenUpdating = False
Dim Tbl As Table, r As Long, c As Long, bFnd As Boolean
1:
For Each Tbl In ActiveDocument.Tables
  With Tbl
    For r = .Rows.Count To 1 Step -1
      With .Rows(r).Range.Find
        .Text = " "
        .Replacement.Text = ""
        .Execute Replace:=wdReplaceAll
        .Text = "^p"
        .Execute
        bFnd = .Found
        End With
      If bFnd = True Then
        .Rows.Add .Rows(r)
        For c = 1 To .Columns.Count
          If .Cell(r + 1, c).Range.Paragraphs.Count > 1 Then
            .Cell(r, c).Range.Text = Split(.Cell(r + 1, c).Range.Text, vbCr)(0)
            .Cell(r + 1, c).Range.Paragraphs(1).Range.Text = vbNullString
          End If
        Next
      End If
    Next
    'End With
  End With
Next
If bFnd = True Then GoTo 1
Application.ScreenUpdating = True
End Sub
 

Gad

Участник
Сообщения
999
Оценка реакций
490
Гм.... что-то он все пробелы убирает в тексте....
Да блин, уже попросил @Linxy заменить на верный вариант :) Но она пока не заходила :)
Эти 2 строки можно просто убрать если что :)
Код:
.Text = " "
.Replacement.Text = ""
 
Последнее редактирование:

RIKITIKI

Топикстартер
15 лет на форуме
Сообщения
1 252
Оценка реакций
401
блин... красота же :)
А я трахался скриптом от Eugenius (спасибо ему конечно) :)
 

Linxy

Девушка с битой
10 лет на форуме
Сообщения
2 273
Оценка реакций
3 840
Да блин, уже попросил @Linxy заменить на верный вариант :)
Дима, я пока с телефона и редактировать очень неудобно. Можешь просто запостить рабочий итоговый вариант новым сообщением?
 

lev

Модератор
15 лет на форуме
Сообщения
1 935
Оценка реакций
1 832
a.png

Не понравилось как макрос работает на ячейках с разным кол-вом строк (хоть у ТС такие и отсутствуют по условию. И GoTo меня несколько удивил. В общем написал свой вариант.
Код:
Sub ParaTabSplitter()
  For Each t In ActiveDocument.Tables
    For Each R In t.Rows
      rr = 1
      For Each cl In R.Cells
        tmp = cl.Range.Paragraphs.Count
        If rr < tmp Then rr = tmp
      Next cl
      If rr > 1 Then
        For Each cl In R.Cells
          txts = Split(cl.Range.Text, vbCr)
          cl.Split rr
          For i = 1 To UBound(txts)
            cl.Column.Cells(i).Range.Text = txts(i - 1)
          Next i
        Next cl
      End If
    Next R
  Next t
End Sub
 

RIKITIKI

Топикстартер
15 лет на форуме
Сообщения
1 252
Оценка реакций
401

lev

Модератор
15 лет на форуме
Сообщения
1 935
Оценка реакций
1 832
b.png

Это при комбинированных ячейках (ваша ошибка при горизонтальном объединении). Ни мой макрос ни @Gad 'а данную ситуацию не обрабатывает. Во избежание остановки работы, можно добавить On Error Resume Next в первую строку макроса.
 

RIKITIKI

Топикстартер
15 лет на форуме
Сообщения
1 252
Оценка реакций
401
при комбинированных ячейках
там нет комбинированных... да и спотыкается на первой же строке...
65432.jpg

если добавляю строку On Error Resume Next - создаёт пустые ячейки, но текст туда не переносит
и ячеек больше чем необходимо
54321.jpg
 

lev

Модератор
15 лет на форуме
Сообщения
1 935
Оценка реакций
1 832
там нет комбинированных...
Чуток загорожено, но не наблюдаю 3-х колонок в самой первой строке "- N -", имхо, там второй и третий столбец скомбинированы.
если добавляю строку On Error Resume Next - создаёт пустые ячейки
Код:
Sub ParaTabSplitter()
  Dim r As Row, cl As Cell, t As Table
  On Error Resume Next
  For Each t In ActiveDocument.Tables
    For Each r In t.Rows
      rr = 1
      For Each cl In r.Cells
        tmp = cl.Range.Paragraphs.Count
        If rr < tmp Then rr = tmp
      Next cl
      If rr > 1 Then
        r.Cells.Split rr
        For Each cl In r.Cells
          txts = Split(cl.Range.Text, vbCr)
          For i = 0 To UBound(txts) - 1
            t.Cell(r.Index + i, cl.ColumnIndex).Range.Text = txts(i)
          Next i
        Next cl
      End If
    Next r
  Next t
End Sub
Новый вариант
 
Последнее редактирование: