DenSyo
Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору красивше все сделал, тестируйте. попробуйте с разным keySet от 0 до 7, второй и третий бит не имеет смысла устанавливать вместе, но проверьте на всякий случай разные варианты. не все случаи отрабатывает объединение по вертикали, но ваш случай отработает верно. Код: Sub test1() Call copyReceivedTable(Application.Documents("received.docm"), Application.Documents("tosend.docx"), "KeywordStart", "KeywordEnd", 0, 0) End Sub ' процедура копирования из таблиц документа docReceive частей таблиц определяемых по ключевым словам keywordStart и keywordEnd в документ docSend ' документы docReceive и docSend должны быть открыты ' необязательные параметры: ' withTables - номер таблицы в документе docReceive к которой применить процедуру, 0 - применить ко всем таблицам ' keySet - флаги обработки копируемых таблиц: ' младший бит - добавить столбец справа ' второй бит - разбить таблицу, убрать объединение ячеек ' третий бит - произвести объединение по вертикали в строках в которых присутствуют объединенные ячейки ' addedColWidth - ширина добавляемого столбца. по умолчанию 30 Sub copyReceivedTable(docReceive As Word.Document, docSend As Word.Document, keywordStart As String, keywordEnd As String, Optional withTables As Long = 0, Optional keySet As Byte = 0, Optional addedColWidth As Double = 30) Dim iCell As Word.Cell Dim Rng As Word.Range Dim l As Long, n As Long, i As Long, j As Long, k() As Long, kk() As Long, t() As Long, doIt() As Long If docReceive.Tables.Count >= 1 Then i = 0 ReDim kk(0 To 0) kk(0) = 1 'задаем флаг чтения ключевого слова начала блока для первого блока (<>0) For j = 1 To docReceive.Tables.Count If withTables = 0 Or j = withTables Then If (keySet And 2) And docReceive.Tables(j).Columns.Count > 1 And docReceive.Tables(j).Rows.Count > 1 Then 'разбить таблицу docReceive.Tables(j).Range.Cells.Split NumRows:=docReceive.Tables(j).Rows.Count, NumColumns:=docReceive.Tables(j).Columns.Count, MergeBeforeSplit:=True End If If (keySet And 4) And docReceive.Tables(j).Columns.Count > 1 And docReceive.Tables(j).Rows.Count > 1 Then 'объединение ячеек по вертикали ReDim doIt(1 To docReceive.Tables(j).Rows.Count) For Each iCell In docReceive.Tables(j).Range.Cells If iCell.RowIndex > 1 Then If Not iCell.Previous Is Nothing Then If (iCell.Previous.RowIndex < iCell.RowIndex Or iCell.ColumnIndex - iCell.Previous.ColumnIndex > 1) And iCell.ColumnIndex > 1 Then doIt(iCell.RowIndex) = 1 If Not iCell.Next Is Nothing Then If (iCell.Next.RowIndex > iCell.RowIndex Or iCell.Next.ColumnIndex - iCell.ColumnIndex > 1) And iCell.ColumnIndex < docReceive.Tables(j).Columns.Count Then doIt(iCell.RowIndex) = 1 End If Next iCell For l = docReceive.Tables(j).Range.Cells.Count To 1 Step -1 If doIt(docReceive.Tables(j).Range.Cells(l).RowIndex) > 0 Then For n = docReceive.Tables(j).Range.Cells(l).RowIndex - 1 To 1 Step -1 On Error Resume Next If Not docReceive.Tables(j).Cell(Row:=n, Column:=docReceive.Tables(j).Range.Cells(l).ColumnIndex) Is Nothing Then Exit For Next n docReceive.Tables(j).Cell(Row:=n, Column:=docReceive.Tables(j).Range.Cells(l).ColumnIndex).Merge mergeto:=docReceive.Tables(j).Range.Cells(l) End If Next l End If If keySet And 1 Then 'добавление столбца справа docReceive.Tables(j).Columns(docReceive.Tables(j).Columns.Count).Width = docReceive.Tables(j).Columns(docReceive.Tables(j).Columns.Count).Width - addedColWidth docReceive.Tables(j).Columns(docReceive.Tables(j).Columns.Count).Select Selection.InsertColumnsRight docReceive.Tables(j).Columns(docReceive.Tables(j).Columns.Count).Width = addedColWidth End If For Each iCell In docReceive.Tables(j).Range.Cells l = Len(iCell.Range.Text) - 2 If l > 0 Then If Left(iCell.Range.Text, l) Like keywordStart & "*" And kk(i) <> 0 Then i = i + 1 ReDim Preserve k(0 To i) ReDim Preserve kk(0 To i) ReDim Preserve t(0 To i) t(i) = j k(i) = iCell.RowIndex End If If (Left(iCell.Range.Text, l) Like keywordEnd & "*" Or iCell.RowIndex = docReceive.Tables(j).Rows.Count) And kk(i) = 0 Then kk(i) = iCell.RowIndex End If Next iCell End If Next j If i > 0 Then For j = 1 To i If kk(j) < docReceive.Tables(t(j)).Rows.Count Then l = docReceive.Tables(t(j)).Cell(kk(j) + 1, 1).Range.Start - 1 Else l = docReceive.Tables(t(j)).Range.End docReceive.Range(Start:=docReceive.Tables(t(j)).Cell(k(j), 1).Range.Start, End:=l).Select Selection.Copy Set Rng = docSend.Content Rng.Collapse Direction:=wdCollapseEnd Rng.Paste Next j End If End If End Sub | PS поправил определение конца копируемого участка, теперь работает с объединенными ячейками | Всего записей: 218 | Зарегистр. 19-01-2008 | Отправлено: 09:53 16-05-2018 | Исправлено: DenSyo, 16:10 16-05-2018 |
|