baston
Junior Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
Kai
Увы, не могу осилить выборку данных из первой таблицы и вставку в другие таблицы: мало знаний и опыта. Слишком сложна структура таблиц, в которой есть еще и объединенные ячейки. Бился...
Могу лишь скинуть код для вставки двух таблиц без данных из первой таблицы внутри них. Может кто-то более грамотный здесь есть?
Рекомендую вам еще задать ваш вопрос на сайт rusfaq.ru в раздел по программированию на VBA (Ссылка).
Код для вставки таблиц:
Код: Sub table_1()
Dim oRange As Range
Dim oTableFrom As Table
Dim oTableTo As Table
Dim oRow As Row
Dim oCell As Cell
Dim sStr As String 'заранее определенный текст
Dim s As String 'текст ячеек первой таблицы
Dim i, j, i1, j1 As Long 'переменные для количества строк в таблицах
Dim tb1() As String
Dim tb2() As String
Set oTableFrom = ActiveDocument.Tables(1)
Set oRange = Selection.Range
sStr = "Какой-то текст, заранее определенный."
ReDim tb1(1 To 20)
ReDim tb2(1 To 10)
tb1(1) = "Описание земельных участков. Раздел " & Chr(171) & "Описание границ" & Chr(187)
tb1(2) = "Кадастровый квартал № ____________________ Изменение №______________________"
tb1(3) = "СВЕДЕНИЯ О ВНОВЬ ОБРАЗОВАННЫХ И ПРЕКРАЩАЮЩИХ СУЩЕСТВОВАНИЕ УЗЛОВЫХ И ПОВОРОТНЫХ ТОЧКАХ ГРАНИЦ"
tb1(4) = "Условное обозначение точки"
tb1(5) = "Координаты"
tb1(6) = "f, м"
tb1(7) = "Описание закрепления точки"
tb1(8) = "Кадастровая запись"
tb1(9) = "Х"
tb1(10) = "У"
tb2(1) = "СВЕДЕНИЯ О ВНОВЬ ОБРАЗОВАННЫХ И ПРЕКРАЩАЮЩИХ СВОЕ СУЩЕСТВОВАНИЕ УЧАСТКАХ ГРАНИЦ"
tb2(2) = "От"
tb2(3) = "т."
tb2(4) = "до"
tb2(5) = "Длина, м"
tb2(6) = "S, м"
tb2(7) = "Дирекционный угол"
tb2(8) = "Описание прохождения границы"
tb2(9) = "Кадастровая запись"
'вставляем текст после таблицы
oRange.EndOf wdStory, wdMove
oRange.InsertAfter vbCr & sStr
oRange.Collapse wdCollapseEnd
oRange.InsertBreak
oRange.Collapse wdCollapseEnd
oRange.Select
Set oTableTo = ActiveDocument.Tables.Add(Selection.Range, 6, 6)
With oTableTo
.Cell(Row:=1, Column:=1).Merge .Cell(1, 6)
.Cell(Row:=2, Column:=1).Merge .Cell(2, 6)
.Cell(Row:=3, Column:=1).Merge .Cell(3, 6)
.Cell(1, 1).Range = tb1(1)
.Cell(2, 1).Range = tb1(2)
.Cell(3, 1).Range = tb1(3)
.Cell(4, 1).Range = tb1(4)
.Cell(Row:=4, Column:=2).Merge .Cell(4, 3)
.Cell(4, 2).Split 2, 1
.Cell(4, 2).Range = tb1(5)
.Cell(5, 2).Split 1, 2
.Cell(5, 2).Range = tb1(9)
.Cell(5, 3).Range = tb1(10)
.Cell(4, 3).Range = tb1(6)
.Cell(4, 4).Range = tb1(7)
.Cell(4, 5).Range = tb1(8)
.Borders.Enable = True
End With
Set oTableTo = Nothing
Erase tb1
oRange.EndOf wdStory, wdMove
oRange.InsertAfter vbCr & vbCr
oRange.Select
Selection.Collapse wdCollapseEnd
Set oTableTo = ActiveDocument.Tables.Add(Selection.Range, 6, 9)
With oTableTo
.Cell(Row:=1, Column:=1).Merge .Cell(1, 9)
.Cell(1, 1).Range = tb2(1)
.Cell(2, 1).Range = tb2(2)
.Cell(2, 2).Range = tb2(3)
.Cell(2, 3).Range = tb2(4)
.Cell(2, 4).Range = tb2(3)
.Cell(2, 5).Range = tb2(5)
.Cell(2, 6).Range = tb2(6)
.Cell(2, 7).Range = tb2(7)
.Cell(2, 8).Range = tb2(8)
.Cell(2, 9).Range = tb2(9)
.Borders.Enable = True
End With
Set oTableTo = Nothing
Erase tb2
End Sub |
|
К сожалению я Visual Basic не знаю... Благодарю! 
