baston
Junior Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
Kai
Откуда данные берутся для определения площади? Слова "Площадь участка:" уже имеются после таблицы (вставлены из дос-документа)? Или это вручную вы вводите?
Добавлено:
Kai
Вот обновленный макрос. Может содержит некоторые избыточные операторы, но главное - работает. Перед использованием выделите ваше число и примените макрос. Если не будет выделено, то появится уведомление об этом. Отпишитесь о результатах.
Код: 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, sStr1, sStr2 As String 'заранее определенный текст
Const ga As Double = 0.0001 'константа для конвертации м2 в га
Dim s, s1 'переменные для выделенного числа и результата вычислений
Dim tb1() As String
Dim tb2() As String
Set oTableFrom = ActiveDocument.Tables(1)
Set oRange = Selection.Range
sStr = " га" & vbCr & vbCr & vbCr & vbCr
sStr1 = "Составил инж. землеустроитель" & vbTab & vbTab & vbTab & vbTab & "Иванов А. К." & vbCr & vbCr & vbCr & vbCr
sStr2 = "Компьютерная обработка" & vbTab & vbTab & vbTab & vbTab & vbTab & "Петров Н. Р."
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) = "Кадастровая запись"
If Selection.Type = wdSelectionIP Then
MsgBox "Не выделен текст"
Else
s = Selection.Text
With Selection
s = Val(s)
s1 = s * ga
s1 = Round(s1, 4)
s = Replace(s, s, s1)
Selection.Text = s
End With
'вставляем текст после таблицы
oRange.EndOf wdStory, wdMove
oRange.InsertAfter sStr & sStr1 & sStr2
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
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
End If
Set oTableTo = Nothing
Erase tb2
End Sub |
|
