Тема: Добавление строк в таблицу согласно одинаковому количеству параграфов
Уныло как-то на форуме, одни смамеры «веселятся». Подкину «код на вентилятор», который добавляет строки в таблицу и переносит непустые параграфы в соответствии с их количеством. Обычная ситуация для двуязычного документа, несколько параграфов, а то и половина документа внесена в одну ячейку таблицы. Соответственно, перевод находится в соседней ячейке. Задача: перенести параграф оригинала текста и перевода в отдельную строку. Проще говоря, в приложении подопытные файлы на которых можно воочию увидеть результат, применив макрос.
Хотелось бы от генералов VBA данного форума получить рекомендации как сделать код более понятней и проще, а другими словами поднабраться опыта.
' добавляем строки в таблицу согласно одинаковому количеству параграфов в ячейках строки
' осущетвлено AlexStar
Sub SplitTableRowOnCoutnOfParagraph()
Dim BackToRow, i, j, TableIndex, CurrentRowIndex, CheckCountOfPrg As Integer
Application.ScreenUpdating = False
On Error GoTo ErrorHandler
If Selection.Information(wdWithInTable) Then
If Selection.Rows.Count = 1 Then ' проверяем выделение одной строки таблицы
i = 1
' ищем и удаляем пустые параграфы, табуляторы, разрыв строки в выделенной строке таблицы (все столбцы)' 32 пробел,
With Selection
While i < .Rows(1).Range.Paragraphs.Count
.Rows(1).Range.Paragraphs(i).Range.Select
Do While .Paragraphs(1).Range.Characters.First = Chr(32) Or .Paragraphs(1).Range.Characters.First = vbCr Or _
.Paragraphs(1).Range.Characters.First = vbTab Or .Paragraphs(1).Range.Characters.First = vbVerticalTab
j = Len(.Rows(1).Range.Paragraphs(i).Range.Text)
.Rows(1).Range.Paragraphs(i).Range.Select
' Удаление символов, защита от зацикливания при невозможности удаления символа (и такое бывает).
.Paragraphs(1).Range.Characters.First.Delete
If j = Len(.Rows(1).Range.Paragraphs(i).Range.Text) And j > 1 Then
Exit Do
End If
Loop
' поднимаем символ конца ячейки на предыдущий параграф
If Right(.Rows(1).Range.Paragraphs(i).Range.Text, 3) = Chr(13) & Chr(7) And .Cells(1).Range.Paragraphs.Count > 1 Then
.Rows(1).Range.Paragraphs(i).Range.Characters.Last.Previous.Delete
i = i - 1
End If
i = i + 1
Wend
End With
If Selection.Cells(1).Range.Paragraphs.Count > 0 Then
TableIndex = ActiveDocument.Range(0, Selection.Tables(1).Range.End).Tables.Count 'получаем индекс таблицы
CurrentRowIndex = Selection.Rows(1).Index ' запоминаем номер строки где находится редактируемый текст
BackToRow = CurrentRowIndex
i = 1
j = ActiveDocument.Tables(TableIndex).Columns.Count ' количество столбцов в таблице
' сравниваем количество непустых параграфов в столбцах
CheckCountOfPrg = ActiveDocument.Tables(TableIndex).Cell(CurrentRowIndex, j).Range.Paragraphs.Count
For j = 1 To ActiveDocument.Tables(TableIndex).Columns.Count
If CheckCountOfPrg <> ActiveDocument.Tables(TableIndex).Cell(CurrentRowIndex, j).Range.Paragraphs.Count Then
MsgBox "Число непустых параграфов в столбцах разное." & vbCr & _
"Для выполнения алгоритма, необходимо одинаковое количество непустых параграфов." & vbCr & _
"Работа остановлена!", vbCritical
Exit Sub
End If
Next j
' основная работа
i = 1
With ActiveDocument.Tables(TableIndex)
j = .Columns.Count ' количество столбцов
While i < Selection.Cells(1).Range.Paragraphs.Count
For j = 1 To .Columns.Count
.Cell(CurrentRowIndex, j).Range.Paragraphs(1).Range.Select
.Cell(CurrentRowIndex, j).Range.Paragraphs(1).Range.Cut
If j = 1 Then
Selection.InsertRowsAbove 1
Else
CurrentRowIndex = CurrentRowIndex - 1
End If
.Cell(CurrentRowIndex, j).Range.Paragraphs(1).Range.Paste
.Cell(CurrentRowIndex, j).Range.Paragraphs(2).Range.Characters.Last.Previous.Delete
CurrentRowIndex = CurrentRowIndex + 1
Next j
If .Columns.Count = 1 Then
CurrentRowIndex = Selection.Rows(1).Index + 1
.Cell(CurrentRowIndex, 1).Select
End If
Wend
End With
End If
Else
MsgBox prompt:="Выделите только одну строку таблицы", Buttons:=vbOKOnly
End If
ActiveDocument.Tables(TableIndex).Cell(BackToRow, 1).Select ' возврат на строку перед добавлением
End If
GoTo Ends:
ErrorHandler:
MsgBox prompt:="Непредвиденная ошибка, что то пошло не так, как задумано!", Title:="Ops...", Buttons:=vbOKOnly + vbCritical
Ends:
Application.ScreenUpdating = True
End Sub
"Кто поработал с многоуровневым списком в Ворде, тот в цирке не смеется"