Много времени уходит на взаимодействие внешней программы с СОМ-сервером.
Возможно стоит сменить алгоритм.
Как-то раз писал маленькую прогу на VBS, которая обрабатывает пару десятков тысяч строк, сложно отформатированную таблицу, несколько упрощает, частично вертикальные данные превращает в горизонтальные.
Сравни, вот первый вариант:
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.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
Dim EX, FileName, i, j, SourceWS, NewWB, NewName, Step, StartRow
Step = 3
StartRow = 2
Set EX = CreateObject("Excel.Application")
FileName = EX.GetOpenFilename("Файлы Excel, *.xl*")
If FileName <> False Then
EX.ScreenUpdating = False
Set SourceWS = EX.Workbooks.Open(FileName).Worksheets(1)
Set NewWB = EX.Workbooks.Add
i = StartRow
j = 2
With NewWB.Worksheets(1)
.Range("A1:S1") = Array("К", "Метро", "адрес", "ОтМ", "Дом", "Площадь", "Б", "Т", "С", "П", "И", _
"Цена,р", "Цена,$", "Цена,e", "$/кв.", "Дата", "СМИ", "Телефоны", "Примечание")
While SourceWS.Cells(i, 1) <> ""
.Cells(j, 1).Value = SourceWS.Cells(i, 1).Value
.Cells(j, 2).Value = SourceWS.Cells(i, 2).Value
.Cells(j, 3).Value = SourceWS.Cells(i + 1, 2).Value
.Cells(j, 4).Value = SourceWS.Cells(i, 3).Value
.Cells(j, 5).Value = SourceWS.Cells(i, 4).Value
.Cells(j, 6).Value = SourceWS.Cells(i, 5).Value
.Cells(j, 7).Value = SourceWS.Cells(i, 6).Value
.Cells(j, 8).Value = SourceWS.Cells(i, 7).Value
.Cells(j, 9).Value = SourceWS.Cells(i, 8).Value
.Cells(j, 10).Value = SourceWS.Cells(i, 9).Value
.Cells(j, 11).Value = SourceWS.Cells(i, 10).Value
.Cells(j, 12).Value = SourceWS.Cells(i, 11).Value
.Cells(j, 13).Value = SourceWS.Cells(i + 1, 11).Value
.Cells(j, 14).Value = SourceWS.Cells(i + 2, 11).Value
.Cells(j, 15).Value = SourceWS.Cells(i, 12).Value
.Cells(j, 16).Value = SourceWS.Cells(i, 13).Value
.Cells(j, 17).Value = SourceWS.Cells(i + 1, 13).Value
.Cells(j, 18).Value = SourceWS.Cells(i, 14).Value
.Cells(j, 19).Value = SourceWS.Cells(i, 15).Value
i = i + Step
j = j + 1
Wend
.Columns("A:R").EntireColumn.AutoFit
End With
NewName = Left(FileName, InStrRev(FileName, ".") - 1) + "_chiv"
NewWB.SaveAs NewName
MsgBox "Создан файл: '" + NewName + "'"
End If
EX.Quit
Set EX = Nothing
и второй вариант:
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.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
Dim EX, FileName, i, j, SourceWS, NewWB, NewName, Step, StartRow, LastRow, m
Step = 3
StartRow = 2
Set EX = CreateObject("Excel.Application")
FileName = EX.GetOpenFilename("Файлы Excel, *.xl*")
If FileName <> False Then
EX.ScreenUpdating = False
Set SourceWS = EX.Workbooks.Open(FileName).Worksheets(1)
Set NewWB = EX.Workbooks.Add
i = StartRow
j = 2
With NewWB.Worksheets(1)
.Range("A1:S1") = Array("К", "Метро", "адрес", "ОтМ", "Дом", "Площадь", "Б", "Т", "С", "П", "И", _
"Цена,р", "Цена,$", "Цена,e", "$/кв.", "Дата", "СМИ", "Телефоны", "Примечание")
SourceWS.Range("Q2").Formula = "=A2"
SourceWS.Range("R2").Formula = "=B2"
SourceWS.Range("S2").Formula = "=B3"
SourceWS.Range("T2").Formula = "=C2"
SourceWS.Range("U2").Formula = "=D2"
SourceWS.Range("V2").Formula = "=E2"
SourceWS.Range("W2").Formula = "=F2"
SourceWS.Range("X2").Formula = "=G2"
SourceWS.Range("Y2").Formula = "=H2"
SourceWS.Range("Z2").Formula = "=I2"
SourceWS.Range("AA2").Formula = "=J2"
SourceWS.Range("AB2").Formula = "=K2"
SourceWS.Range("AC2").Formula = "=K3"
SourceWS.Range("AD2").Formula = "=K4"
SourceWS.Range("AE2").Formula = "=L2"
SourceWS.Range("AF2").Formula = "=M2"
SourceWS.Range("AG2").Formula = "=M3"
SourceWS.Range("AH2").Formula = "=N2"
SourceWS.Range("AI2").Formula = "=O2"
LastRow = SourceWS.Range("A1").SpecialCells(11).Row 'xlLastCell=11
m = (LastRow - StartRow + 1) Mod Step
if m = 0 then m = Step
LastRow = LastRow + (Step - m)
SourceWS.Range("Q2:AI4").AutoFill SourceWS.Range(SourceWS.Range("Q2"), SourceWS.Cells(LastRow, 35))
.Range(.Range("A2"), .Cells(LastRow, 19)).Value = SourceWS.Range(SourceWS.Range("Q2"), SourceWS.Cells(LastRow, 35)).Value
.Cells.Sort .Range("A2"), 1, , , , , , 0 'xlAscending=1, xlGuess=0
.Columns("A:R").EntireColumn.AutoFit
.Rows("1:1").Interior.ColorIndex = 15
.Range("A2").Select
NewWB.Windows(1).FreezePanes = True
.Cells.AutoFilter
End With
NewName = Left(FileName, InStrRev(FileName, ".") - 1) + "_chiv"
NewWB.SaveAs NewName
NewWB.Close
SourceWS.Parent.Close False
MsgBox "Создан файл: '" + NewName + "'"
End If
EX.Quit
Set EX = Nothing
Делают они одно и тоже. Первый работает минут 15, второй - несколько секунд. |
