Доброго времени суток, уважаемые форумчане! В макросах не силен, по статейкам в инете написал код. Смысл такой, что в таблицу сначала вставляется необходимое количество строк, затем из буфера обмена (ранее скопированного диапазона в excel) вставляется в диапазон ячеек таблицы word (выбирается таблица №3). Далее перебираются ячейки 3 столбца и при условии, что в ячейке 3 символа, копируется в буфер содержимое ячейки второго столбца, строка очищается, ячейки в строке объединяются и затем в строку вставляется ранее скопированное содержимое ячейки второго столбца, ну и для красоты ячейка затемняется. Проблема в том, что в случае, например, двухста строк код выполняется более менее быстро, а вот когда строк, например, две тысячи, код выполняется настолько долго, что через 15-20 минут, не дождавшись окончания, снимаю задачу диспетчером. Не могу понять, что можно предпринять для исправления.
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
Sub Import()
On Error Resume Next
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument
n = Val(InputBox("Сколько строк в таблице?"))
If n = 0 Then Exit Sub
k = n - 1 'корректировка количества строк
r = n + 1 'корректировка количества строк
With .Tables(3) 'обращаюсь к третьей таблице
.Rows(2).Select 'выбираю позицию для добавления строк
Selection.InsertRowsBelow k 'вставвка заданного количества строк
.Rows(1).Borders(wdBorderBottom).LineStyle = wdLineStyleDouble 'красявости
.Rows(r).Borders(wdBorderBottom).LineStyle = wdLineStyleDouble 'красявости
rs = .Cell(2, 2).Range.Start 'начало дипазона для вставки
re = .Cell(r, 6).Range.End 'конец дипазона для вставки
ActiveDocument.Range(rs, re).Paste 'вставка из буфера в заданный диапазон
For i = 2 To r
If .Cell(i, 3).Range.Characters.Count = 3 Then 'определение строки для форматирования
.Cell(i, 2).Range.Copy 'копирую в память содержимое ячейки
.Rows(i).Range.Delete Unit:=wdCharacter, Count:=1 'очистка строки
.Cell(i, 1).Merge MergeTo:=.Cell(i, 6) 'объединение ячеек
.Rows(i).Range.Paste 'вставка ранее запомненного значения
.Rows(i).Shading.BackgroundPatternColor = wdColorGray15 'красявости
End If
Next
End With
End With
Application.ScreenUpdating = True
End Sub
Подскажите, пожалуйста, в чем ошибка в коде, существует ли способ ли ускорить его выполнение? Заранее спасибо.
