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

[RIKITIKI]

Добрый день!
Имеется таблица. В некоторых строках которой не один абзац, а скажем четыре. То есть в каждой ячейке такой строки по четыре абзаца. Есть ли какой-то макрос для разбивки таких строк поабзацно?

 

[Linxy]

Наш @Eugenyus вроде подходящий как раз скрипт выкладывал:

Разбить строку таблицы по абзацам - СКРИПТЫ для Adobe InDesign

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

eugenyus.rudtp.ru

 

[RIKITIKI]

Да, я пользуюсь... только утомительно в каждой ячейке запускать....
Хотелось найти решение в Ворде и для всего файла сразу

 

[Linxy]

Вот тут товарищи похожий макрос сочинили

Word table find paragraph break, split row content in to two row

The word tables having variable number of rows and columns. The below code I have taken from previously answered in this forum and try to modify it. However, due lack of knowledge I could find or a...

stackoverflow.com

 

[imma]

только утомительно в каждой ячейке запускать....

Convert table to text -> Convert text to table

 

[lev]

Convert table to text -> Convert text to table

 

[Gad]

Посмотреть вложение 133872

Convert table to text -> Convert text to table - [Объединить ячейки в каждом столбце] - Convert table to text -> Convert text to table
Направление верно было задано
Можно так еще: Ctrl+C > Excel > Ctrl+V > Ctrl+C > Word > Ctrl+V

 

[imma]

Копируем таблицу из Word, помещаем в Excel, копируем из Excel, помещаем в InD.

 

[Gad]

Хотелось найти решение в Ворде и для всего файла сразу

С подачи @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

 

[RIKITIKI]

С подачи

Гм.... что-то он все пробелы убирает в тексте....

 

[Gad]

Гм.... что-то он все пробелы убирает в тексте....

Да блин, уже попросил @Linxy заменить на верный вариант Но она пока не заходила
Эти 2 строки можно просто убрать если что

.Text = " "
.Replacement.Text = ""

 

[RIKITIKI]

блин... красота же
А я трахался скриптом от Eugenius (спасибо ему конечно)

 

[Linxy]

Да блин, уже попросил @Linxy заменить на верный вариант

Дима, я пока с телефона и редактировать очень неудобно. Можешь просто запостить рабочий итоговый вариант новым сообщением?

 

[Gad]

Можешь просто запостить рабочий итоговый вариант новым сообщением

Теперь уже после того как @RIKITIKI его погоняет и поправлю что будет глючить

 

[lev]

Не понравилось как макрос работает на ячейках с разным кол-вом строк (хоть у ТС такие и отсутствуют по условию. И 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

 

[Gad]

GoTo меня несколько удивил

Не хотел особо переделывать Но таки да, нужно просто переписать его полностью

 

[RIKITIKI]

увы

 

[lev]

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

 

[RIKITIKI]

при комбинированных ячейках

там нет комбинированных... да и спотыкается на первой же строке...


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

 

[lev]

там нет комбинированных...

Чуток загорожено, но не наблюдаю 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

Новый вариант