[Andreyvn]

Всем привет!

Народ, прошу помощи! Обрабатываю в VBA таблицы, несколько таблиц с одинаковым содержимым первой строки сливаю в одну таблицу, при количестве таблиц ок. 50 макрос выполняется 2 часа.

Код хотя и громоздкий, по сути простой.
Большие подозрения, что что-то накапливается в памяти и поэтому падает быстродействие.
Посоветуйте, pls, что попробовать?

Код:

[Выделить все]

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "ThisDrawing"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
 
 
Public S1, S2, S3, S4 As Variant
 
 
 
 
Sub MakeApparatus()
Dim JointNum As Integer 'номер строки сводной таблицы
 
    Dim CurrentDOC As AcadDocument
 
    Dim MyModelSpace As AcadModelSpace
    Set MyModelSpace = ThisDrawing.ModelSpace
 
   ' создать сводную таблицу на текущем листе
    Dim pt(2) As Double
    Dim MyTable As IAcadTable
    ' pt()-координаты, NumRow,NumColumn,RowHeight, ColWidth
    Set MyTable = MyModelSpace.AddTable(pt, 2, 5, 4, 30)
 
    Call MyTable.SetColumnWidth(0, 10)  'номер (это поле создается)
    Call MyTable.SetColumnWidth(1, 30)  'Наименование изделия
    Call MyTable.SetColumnWidth(2, 50)  'Описание изделия
    Call MyTable.SetColumnWidth(3, 20)  'Обозначение
    Call MyTable.SetColumnWidth(4, 20)  'Присоединение (группа)
    Call MyTable.SetCellValue(0, 0, "JointTablApparatus")
    Call MyTable.SetCellValue(1, 0, "N")
    Call MyTable.SetCellValue(1, 1, "Наименование")
    Call MyTable.SetCellValue(1, 2, "Описание")
    Call MyTable.SetCellValue(1, 3, "Обозначение")
    Call MyTable.SetCellValue(1, 4, "Присоединение")
 
    Call MyTable.SetCellTextStyle(0, 0, "Standard") 'Стиль Standard доступен для редактирования при вставке таблицы
    Call MyTable.SetCellTextStyle(1, 1, "Standard")
    Call MyTable.SetCellTextStyle(1, 2, "Standard")
    Call MyTable.SetCellTextStyle(1, 3, "Standard")
    Call MyTable.SetCellTextStyle(1, 4, "Standard")
 
    Call MyTable.SetCellTextHeight(1, 0, 2)
    Call MyTable.SetCellTextHeight(1, 1, 2.5)
    Call MyTable.SetCellTextHeight(1, 2, 2.5)
    Call MyTable.SetCellTextHeight(1, 3, 2.5)
    Call MyTable.SetCellTextHeight(1, 4, 2.5)
 
    Call MyTable.SetCellAlignment(0, 0, acBottomLeft)
    Call MyTable.SetCellAlignment(1, 0, acMiddleCenter)
    Call MyTable.SetCellAlignment(1, 1, acMiddleCenter)
    Call MyTable.SetCellAlignment(1, 2, acMiddleCenter)
    Call MyTable.SetCellAlignment(1, 3, acMiddleCenter)
    Call MyTable.SetCellAlignment(1, 4, acMiddleCenter)
 
 
    JointNum = 2 'Начальное значение указателя строки сводной таблицы
 
    ' найти все таблицы с пометкой в первой строке
      Call JointTable1(JointNum, MyTable)
 
End Sub
 
 
'  Ver1  Собираем данные из таблиц Apparatus по текущему чертежу
Sub JointTable1(JointNum, MyTable)
    ' Программа собирает данные из всех таблиц чертежа1 с именем Apparatus (нулевая строка таблицы)
    ' и собирает их в сводной таблице JointTable на текущем листе2
    Dim objCount As Integer
    Dim i As Integer
    Dim j As Integer
    Dim MaxRows As Integer
    Dim StrFromTable1, StrFromTable2, StrFromTable3, StrFromTable4 As Variant
 
    Dim TableName As String
 
    objCount = ThisDrawing.ModelSpace.Count 'Всего объектов на чертеже вновь открытого файла
    Dim mspaceObj As AcadObject
    'перебираем все объекты чертежа и обрабатываем таблицы
    For i = 0 To objCount - 1
     Set mspaceObj = ThisDrawing.ModelSpace.Item(i)
           If mspaceObj.ObjectName = "AcDbTable" Then
               TableName = mspaceObj.GetCellValue(0, 0) 'выдернем заголовок таблицы
               If TableName = "Apparatus" Then ' Обрабатываем только Таблицы - Apparatus
                   ' Перебираем ячейки таблицы Строки и столбцы нумруются от 0, оставляем верхнюю строку для заголовка
                   MaxRows = mspaceObj.Rows
                   For j = 1 To MaxRows - 1
                     ' Прочитать данные из строки исходной из таблицы:
                     StrFromTable1 = mspaceObj.GetCellValue(j, 0)
                     StrFromTable2 = mspaceObj.GetCellValue(j, 1)
                     StrFromTable3 = mspaceObj.GetCellValue(j, 2)
                     StrFromTable4 = mspaceObj.GetCellValue(j, 3)
                     ' Добавить строку и Записать данные в сводную таблицу - на другом листе!
                     ' Переключиться на другой лист
                     'JointDOC.Activate
                     S1 = StrFromTable1
                     S2 = StrFromTable2
                     S3 = StrFromTable3
                     S4 = StrFromTable4
                    ' Все поля должны быть текстовыми !!! (тип Variant не помогает)
                     Call MyTable.InsertRows(JointNum, 8, 1)
                     Call MyTable.SetCellValue(JointNum, 0, JointNum - 1)  '
                     Call MyTable.SetCellValue(JointNum, 1, "" + S1) ' наименование
                     Call MyTable.SetCellValue(JointNum, 2, "" + S2) ' Описание
                     Call MyTable.SetCellValue(JointNum, 3, "" + S3) ' Обозначение
                     Call MyTable.SetCellValue(JointNum, 4, "" + S4) ' Присоединение (группа)
 
                     Call MyTable.SetCellTextStyle(JointNum, 0, "Standard")
                     Call MyTable.SetCellTextStyle(JointNum, 1, "Standard")
                     Call MyTable.SetCellTextStyle(JointNum, 2, "Standard")
                     Call MyTable.SetCellTextStyle(JointNum, 3, "Standard")
                     Call MyTable.SetCellTextStyle(JointNum, 4, "Standard")
                     Call MyTable.SetCellTextHeight(JointNum, 0, 2)
                     Call MyTable.SetCellTextHeight(JointNum, 1, 2.5)
                     Call MyTable.SetCellTextHeight(JointNum, 2, 2.5)
                     Call MyTable.SetCellTextHeight(JointNum, 3, 2.5)
                     Call MyTable.SetCellTextHeight(JointNum, 4, 2.5)
                     Call MyTable.SetCellAlignment(JointNum, 0, acMiddleCenter)
                     Call MyTable.SetCellAlignment(JointNum, 1, acMiddleCenter)
                     Call MyTable.SetCellAlignment(JointNum, 2, acMiddleCenter)
                     Call MyTable.SetCellAlignment(JointNum, 3, acMiddleCenter)
                     Call MyTable.SetCellAlignment(JointNum, 4, acMiddleCenter)
 
 
 
                     JointNum = JointNum + 1
 
 
                   Next j ' конец перебора строк выбранной таблицы
               End If
           End If
    Next i 'конец перебора объектов чертежа
 
End Sub

[Vildar]

Попробуй включить RegenerateTableSuppressed у объекта таблицы перед заполнением ее данными, а после выключи этот флаг.

[Дима_]

А попробовать вначале все прочитать - а потом записать.

[Andreyvn]

Попробуй включить RegenerateTableSuppressed у объекта таблицы перед заполнением ее данными, а после выключи этот флаг.

Да, это оно!
Макрос который зависал на 2-3 часа теперь выполняется за 3-4 сек.

Спасибо!