Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Курилка
Страницы: 1
RSS
Замедление работы макросов в фоновом режиме на ноутбучном железе
 
#1
11.12.2025 09:45:43
Всех  приветствую! Если тема уже обсуждалась, то прошу сильно не пинать.
Суть проблемы:
Есть рабочий стационарный компьютер (12400, 32 Гб оперативы, ssd 512 m2)  и есть домашний ноутбук (ultra 255h, 16 Гб оперативы, ssd 512 m2), программная часть на обеих машинах одинаковая Win 10 pro, Эксель 365. На рабочем компьютере макрос в любом режиме (т.е. находишься в самом Экселе или выполняешь другую работу (браузер, проводник, pdf и т.д)) отрабатывает стабильно за условные  180 сек. При этом на ноутбуке ситуация немного другая. Если находишься в самом экселе, то макрос отрабатывает за 157 сек (режим питания сбалансированный), но когда условно начинаю делать тоже, что на стационарном компьютере (браузер, проводник, pdf и т.д), то ситуация меняется в худшую сторону: на режиме сбалансированный  около 400 сек, на режиме высокая производительность 230 сек. На зарубежных форумах читал про установку приоритета в диспетчере задач, но все равно результата в 157  сек так и не достиг даже близко.
Сисадмин на работе говорит, что связано с энергоэффективностью новых ноутбучных процессоров и что это сейчас норма. Но, по-моему, так не должно быть.
Может кто сталкивался с таким поведением и как это победить?
 
 
 
#2
12.12.2025 11:56:28
Скрытый текст

    • Изменено: Тимофеев - 12.12.2025 18:39:00
     
     
     
    #3
    12.12.2025 12:26:44
    Alex, покажите ваш макрос, может быть его можно распараллелить и сильно убыстрить
     
     
     
    #4
    12.12.2025 13:05:00
    Всех приветствую!
    Тимофеев, спасибо большое. Дома вечером поэкспериментирую. О результатах отпишусь.
    testuser, во вложении, мне не жалко :)  
    Наверное, можно его немного еще ускорить, не все там так оптимально, знаний не хватает.
    Но, думаю, не стоит тратить время на разбор чужого кода, меня временные затраты работы макроса устаивают. Тут, наверное, больше вопрос к связке операционная система + процессор для параллельной работы разных приложений на ноутбуках. А с этим в угоду энергоэффективности у современного железа походу беда :cry:  
    Изменено: Alex - 12.12.2025 13:05:24
     
     
     
    #5
    12.12.2025 13:24:21
    Код
    Мы имеем дело с большим макросом, который обрабатывает несколько файлов данных (продажи, прайс, структура, штрихкод, остатки) и заполняет шаблон.
Проблема в том, что на ноутбуке макрос работает медленнее, особенно когда Excel не в фокусе.
Из кода видно, что макрос использует много операций с листами и массивами. Основные моменты, которые могут тормозить:
Открытие и закрытие рабочих книг (файлов) - каждый раз это операции с диском и Excel.Работа с листами (удаление строк/столбцов, копирование, вставка).
Возможно, медленная работа словаря (Dictionary) при большом объеме данных.
Но главная проблема, как вы описали, - разница в производительности между активным и неактивным окном.
Это связано с энергосбережением процессора ноутбука.
Давайте разберем, что можно сделать:
Оптимизация кода VBA (общие советы):Убедиться, что включены все оптимизации (отключение обновления экрана, ручной расчет и т.д.)
- в коде это уже есть в clstSheetTransformation.Speed_Up_Transformation.
Минимизировать обращения к ячейкам (работа через массивы) - в коде это в основном соблюдается.
Использовать более эффективные алгоритмы и структуры данных.
Проблема с энергосбережением ноутбука:
Вы уже пробовали изменить режим питания, но это не дало полного эффекта.
Возможно, нужно принудительно заставить процессор работать на максимальной частоте во время выполнения макроса.
Возможное решение: Использовать Windows API для повышения приоритета процесса Excel и, возможно, удержания частоты процессора.
Я вижу, что в коде уже используется таймер (clsTimer) для замеров. Вы можете добавить замеры в каждую секцию, чтобы найти узкие места.
Но учитывая, что проблема в энергосбережении, давайте сосредоточимся на том, как заставить процессор работать на полную.
Предлагаю следующее:
Настройка схемы электропитания:
В настройках электропитания (Панель управления -> Электропитание) выберите схему "Высокая производительность".
Если такой схемы нет, создайте ее. Также можно изменить дополнительные параметры питания, установив минимальное и максимальное состояние процессора на 100%.Использование API для управления состоянием процессора:Можно попробовать использовать функцию SetThreadExecutionState для предотвращения перехода в режим энергосбережения во время выполнения макроса.Повышение приоритета процесса Excel:Вы уже пробовали менять приоритет в диспетчере задач. Это можно делать и из кода VBA, но это может быть небезопасно.Оптимизация кода:Проверьте, нет ли операций, которые можно исключить или оптимизировать. Например, в коде много раз открываются и закрываются одни и те же файлы? Возможно, можно открыть каждый файл один раз и затем брать данные с разных листов.Использование более быстрых методов:Например, использование Application.Match вместо циклов в некоторых случаях.Проверка, что словарь (Dictionary) настроен на нужный режим сравнения (в коде используется TextCompare, который медленнее, чем BinaryCompare). Если не требуется регистронезависимое сравнение, перейдите на BinaryCompare.Возможно, проблема в одном из модулей:Модуль modBarCode использует Power Query (через WorkbookQuery), что может быть медленным.Давайте попробуем добавить API-вызов для предотвращения ухода в сон и посмотрим, поможет ли это.Добавьте в модуль (например, modMain) следующий код:vba



Private Declare PtrSafe Function SetThreadExecutionState Lib "kernel32" (ByVal esFlags As Long) As Long

Private Const ES_CONTINUOUS = &H80000000
Private Const ES_SYSTEM_REQUIRED = &H1
Private Const ES_AWAYMODE_REQUIRED = &H40
И в начале макроса main_sub добавьте:vba



    ' Запрещаем переход в спящий режим и выключаем энергосбережение для процесса
    SetThreadExecutionState ES_CONTINUOUS Or ES_SYSTEM_REQUIRED Or ES_AWAYMODE_REQUIRED)
А в конце макроса:vba



    ' Восстанавливаем нормальный режим энергосбережения
    SetThreadExecutionState(ES_CONTINUOUS)
Также можно попробовать повысить приоритет процесса Excel через API:vba



Private Declare PtrSafe Function GetCurrentProcess Lib "kernel32" () As LongPtr
Private Declare PtrSafe Function SetPriorityClass Lib "kernel32" (ByVal hProcess As LongPtr, ByVal dwPriorityClass As Long) As Long
Private Const HIGH_PRIORITY_CLASS = &H80
Private Const REALTIME_PRIORITY_CLASS = &H100
И в начале макроса:vba



    Dim hProcess As LongPtr
    hProcess = GetCurrentProcess()
    SetPriorityClass hProcess, HIGH_PRIORITY_CLASS
Но будьте осторожны с повышением приоритета, особенно до Realtime, так как это может привести к зависаниям системы.Кроме того, попробуйте изменить режим сравнения словаря на BinaryCompare (если это допустимо для ваших данных). В коде модуля modMain в строке:vba



    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = TextCompare
Если данные не требуют регистронезависимого сравнения, замените на:vba



    dict.CompareMode = BinaryCompare
Или вообще удалите строку с CompareMode, так как по умолчанию используется BinaryCompare.Также обратите внимание на модуль modBarCode. В нем используется Power Query, который может быть медленным. Возможно, есть альтернативные способы обработки штрихкодов.Если после всех этих мер проблема останется, возможно, стоит рассмотреть возможность переписать самые медленные части кода на C++ и использовать ATL, как мы обсуждали ранее, но это крайняя мера.Попробуйте предложенные изменения и замерьте время выполнения. Если будут улучшения, но все равно не достаточно, то будем думать дальше.



Отлично, теперь я вижу весь код! Это действительно сложный макрос для обработки данных, который работает с несколькими файлами. Давайте проанализируем, почему на ноутбуке он работает медленнее, особенно в фоновом режиме.Основные проблемы производительности:1. Многократное открытие/закрытие файловvba



' В каждом модуле происходит открытие файлов
Set wb = Workbooks.Open(path & strName)
' ... обработка ...
wb.Close savechanges:=False
Проблема: Каждый файл открывается и закрывается отдельно. Особенно в модулях:modSales - 3 раза открывает "продажи.xlsx"modPrice, modStructure, modBarCode, modOstatki - каждый свой файл2. Интенсивная работа с листамиМного операций с листами:clean_sheet вызывает удаление пустых строк/столбцовUsedRange операцииAdvancedFilter в modPrice и modStructure3. Использование PowerQuery в modBarCodevba



' Это может быть очень медленно
Call AddNewQuery(aWs.Parent, LO.Name, sNameToGroup, arr)
4. Большие массивы данныхРабота с массивами через Application.Index, копирование диапазонов.Оптимизации для ноутбука:Оптимизация 1: Блокировка обновления экрана и расчетовДобавьте в начало main_sub:vba



Public Sub main_sub()
    ' ===== ДОБАВЬТЕ ЭТО =====
    Dim calcState As XlCalculation
    Dim screenState As Boolean
    Dim eventsState As Boolean
    Dim statusBarState As Boolean
    
    ' Сохраняем текущие настройки
    With Application
        calcState = .Calculation
        screenState = .ScreenUpdating
        eventsState = .EnableEvents
        statusBarState = .DisplayStatusBar
        
        ' Отключаем всё для ускорения
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayStatusBar = False
        .DisplayAlerts = False
    End With
    ' ========================
    
    ' ... существующий код ...
    
    ' ===== В КОНЦЕ ВЕРНИТЕ НАСТРОЙКИ =====
    With Application
        .Calculation = calcState
        .ScreenUpdating = screenState
        .EnableEvents = eventsState
        .DisplayStatusBar = statusBarState
        .DisplayAlerts = True
    End With
    ' =====================================
End Sub
Оптимизация 2: Кэширование открытых файловСоздайте новый модуль для кэширования файлов:vba



' Module: modFileCache
Option Explicit

Private FileCache As Object

Public Sub InitializeCache()
    Set FileCache = CreateObject("Scripting.Dictionary")
End Sub

Public Function GetCachedWorkbook(ByVal fullPath As String) As Workbook
    Dim wb As Workbook
    
    If FileCache.Exists(fullPath) Then
        Set wb = FileCache(fullPath)
    Else
        Set wb = Workbooks.Open(fullPath, ReadOnly:=True, UpdateLinks:=False)
        FileCache.Add fullPath, wb
    End If
    
    Set GetCachedWorkbook = wb
End Function

Public Sub CloseAllCached()
    Dim key As Variant
    For Each key In FileCache.Keys
        On Error Resume Next
        FileCache(key).Close SaveChanges:=False
    Next key
    Set FileCache = Nothing
End Sub
Измените функции загрузки данных:vba



Public Sub get_data_sales(ByVal path As String, ByRef arr As Variant, ByVal sh_ind As Long)
    Const strName As String = "продажи.xlsx"
    Dim fullPath As String
    fullPath = path & strName
    
    If Dir(fullPath) <> "" Then
        ' Используем кэшированный файл
        Dim wb As Workbook
        Set wb = GetCachedWorkbook(fullPath)
        
        ' ... остальной код без wb.Close ...
    End If
End Sub
В main_sub добавьте:vba



InitializeCache
' ... выполнение ...
CloseAllCached
Оптимизация 3: Замена PowerQuery на обычные методыВ modBarCode.CreateBarCodeReport замените PowerQuery на обычную обработку:vba



Sub CreateBarCodeReport_Optimized(ByVal aWs As Worksheet, ByVal num_art As Long, ByRef arr As Variant)
    ' Упрощенная версия без PowerQuery
    
    Dim dataArr As Variant
    Dim dict As Object
    Dim i As Long, lastRow As Long, codeCol As Long, barcodeCol As Long
    Dim key As String, barcodes As String
    
    ' Находим колонки
    With aWs
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        
        ' Ищем колонку с кодом
        For i = 1 To 10 ' предполагаем первые 10 колонок
            If InStr(1, .Cells(1, i).Value, "Код", vbTextCompare) > 0 Or _
               InStr(1, .Cells(1, i).Value, "Артикул", vbTextCompare) > 0 Then
                codeCol = i
            ElseIf InStr(1, .Cells(1, i).Value, "Штрихкод", vbTextCompare) > 0 Then
                barcodeCol = i
            End If
        Next i
        
        If codeCol = 0 Or barcodeCol = 0 Then Exit Sub
        
        ' Читаем данные
        dataArr = .Range(.Cells(1, codeCol), .Cells(lastRow, barcodeCol)).Value
    End With
    
    ' Обрабатываем через словарь
    Set dict = CreateObject("Scripting.Dictionary")
    
    For i = 2 To UBound(dataArr, 1) ' пропускаем заголовок
        key = Trim(CStr(dataArr(i, 1)))
        If Len(key) > 0 Then
            If Not dict.Exists(key) Then
                dict(key) = ""
            End If
            
            If Len(Trim(CStr(dataArr(i, 2)))) > 0 Then
                If Len(dict(key)) > 0 Then
                    dict(key) = dict(key) & ", " & Trim(CStr(dataArr(i, 2)))
                Else
                    dict(key) = Trim(CStr(dataArr(i, 2)))
                End If
            End If
        End If
    Next i
    
    ' Конвертируем в массив
    ReDim arr(1 To dict.Count, 1 To 2) As Variant
    i = 1
    Dim dictKey As Variant
    For Each dictKey In dict.Keys
        arr(i, 1) = dictKey
        arr(i, 2) = dict(dictKey)
        i = i + 1
    Next dictKey
End Sub
Оптимизация 4: Пакетная обработка словарейВ main_sub много операций со словарями. Объедините:vba



' Вместо многократного:
'dict.RemoveAll
'get_data_...
'fill_dict_post...
'dict_to_array...

' Сделайте одну функцию:
Public Sub ProcessMultipleDataSets(ByRef mainArray As Variant, ByVal orderArray As Variant, _
                                   ByVal path As String, ByVal fileType As String, _
                                   ByVal params As Variant)
    ' Объединенная обработка
End Sub
Оптимизация 5: Ускорение работы с массивамиЗамените медленные операции:vba



' Вместо цикла:
'For i = LBound(tmp_arr, 1) To UBound(tmp_arr, 1)
'    order_arr(i, 1) = tmp_arr(i, 1)
'Next i

' Используйте более быстрый метод:
Public Sub FastCopyColumn(ByRef sourceArray As Variant, ByRef destArray As Variant, _
                          ByVal sourceCol As Long, ByVal destCol As Long)
    Dim i As Long
    For i = LBound(sourceArray, 1) To UBound(sourceArray, 1)
        destArray(i, destCol) = sourceArray(i, sourceCol)
    Next i
End Sub
Оптимизация 6: Предотвращение "засыпания" процессораДобавьте в modMain:vba



#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare PtrSafe Function SetThreadExecutionState Lib "kernel32" _
        (ByVal esFlags As Long) As Long
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare Function SetThreadExecutionState Lib "kernel32" _
        (ByVal esFlags As Long) As Long
#End If

Private Const ES_SYSTEM_REQUIRED = &H1
Private Const ES_CONTINUOUS = &H80000000

Public Sub PreventSleep()
    ' Предотвращает переход в спящий режим
    SetThreadExecutionState ES_CONTINUOUS Or ES_SYSTEM_REQUIRED
End Sub

Public Sub AllowSleep()
    ' Разрешает спящий режим
    SetThreadExecutionState ES_CONTINUOUS
End Sub
В main_sub:vba



PreventSleep
' ... код ...
AllowSleep
Оптимизация 7: Ускорение операций с листамиЗамените clean_sheet на более эффективную версию:vba



Public Sub clean_sheet_fast(ByVal sh As Worksheet)
    ' Быстрая очистка без лишних вызовов
    Dim lastRow As Long, lastCol As Long
    Dim rng As Range
    
    With sh
        .DisplayPageBreaks = False
        
        ' Быстро определяем реальные границы
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        
        If lastRow > 10000 Or lastCol > 100 Then
            ' Для больших диапазонов используем более быстрый метод
            Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
            
            ' Удаляем пустые строки пакетами
            Dim i As Long
            For i = lastRow To 1 Step -100
                Dim chunkStart As Long
                chunkStart = Application.Max(1, i - 99)
                Dim chunkRng As Range
                Set chunkRng = .Range(.Cells(chunkStart, 1), .Cells(i, lastCol))
                
                If Application.CountA(chunkRng) = 0 Then
                    chunkRng.EntireRow.Delete
                End If
            Next i
        Else
            ' Для маленьких диапазонов - обычный метод
            Dim trSh As clstSheetTransformation
            Set trSh = New clstSheetTransformation
            Set trSh.current_sheet = sh
            trSh.Delete_Empty_RowOrColumn_UsdRng _
                trSh.Get_Number_Of_Last_RowOrColumn(enRow), enRow
        End If
    End With
End Sub
Оптимизация 8: Кэширование результатов вычисленийДобавьте кэширование для часто используемых данных:vba



' Module: modCache
Option Explicit

Private Type CacheItem
    Key As String
    Value As Variant
    Timestamp As Date
End Type

Private Cache() As CacheItem
Private CacheSize As Long

Public Sub AddToCache(ByVal key As String, ByVal value As Variant)
    Dim i As Long
    For i = 0 To CacheSize - 1
        If Cache(i).Key = key Then
            Cache(i).Value = value
            Cache(i).Timestamp = Now
            Exit Sub
        End If
    Next i
    
    ' Добавляем новый элемент
    ReDim Preserve Cache(CacheSize)
    Cache(CacheSize).Key = key
    Cache(CacheSize).Value = value
    Cache(CacheSize).Timestamp = Now
    CacheSize = CacheSize + 1
End Sub

Public Function GetFromCache(ByVal key As String) As Variant
    Dim i As Long
    For i = 0 To CacheSize - 1
        If Cache(i).Key = key Then
            GetFromCache = Cache(i).Value
            Exit Function
        End If
    Next i
    GetFromCache = Empty
End Function
Оптимизация 9: Параллельная обработка (если возможно)Хотя VBA однопоточный, можно использовать "логическое" разделение:vba



Public Sub ProcessInChunks(ByVal dataArray As Variant, ByVal chunkSize As Long)
    Dim i As Long, chunkCount As Long
    chunkCount = (UBound(dataArray, 1) - LBound(dataArray, 1)) \ chunkSize + 1
    
    For i = 1 To chunkCount
        Dim startIdx As Long, endIdx As Long
        startIdx = (i - 1) * chunkSize + LBound(dataArray, 1)
        endIdx = Application.Min(startIdx + chunkSize - 1, UBound(dataArray, 1))
        
        ' Обрабатываем чанк
        ProcessChunk dataArray, startIdx, endIdx
        
        ' Обновляем прогресс (для отображения активности)
        DoEvents
    Next i
End Sub
Оптимизация 10: Минимизация обращений к дискуИзмените логику работы с файлами:vba



Public Sub LoadAllFilesAtOnce(ByVal path As String)
    ' Открываем все файлы один раз
    Dim files As Object
    Set files = CreateObject("Scripting.Dictionary")
    
    ' Предзагрузка всех необходимых файлов
    Dim fileList As Variant
    fileList = Array("продажи.xlsx", "прайс.xlsx", "Структура.xlsx", _
                     "штрихкод.xlsx", "остатки.xlsx")
    
    Dim f As Variant
    For Each f In fileList
        If Dir(path & f) <> "" Then
            files.Add f, Workbooks.Open(path & f, ReadOnly:=True, UpdateLinks:=False)
        End If
    Next f
    
    ' Теперь все данные доступны без повторного открытия/закрытия
    ' ... обработка ...
    
    ' Закрываем всё в конце
    Dim wb As Variant
    For Each wb In files.Items
        wb.Close SaveChanges:=False
    Next wb
End Sub
Готовый оптимизированный main_sub:vba



Sub main_sub_optimized()
    ' Начальные настройки
    Dim appState As New AppStateSaver
    appState.SaveAndDisable
    
    Dim sleepPreventer As New SleepPreventer
    sleepPreventer.Prevent
    
    Dim fileCache As New FileCache
    fileCache.Initialize
    
    ' Основная обработка
    On Error GoTo ErrorHandler
    
    ' ... ваш код с оптимизациями ...
    
Cleanup:
    ' Восстановление
    fileCache.CloseAll
    sleepPreventer.Allow
    appState.Restore
    Exit Sub
    
ErrorHandler:
    MsgBox "Ошибка: " & Err.Description, vbCritical
    GoTo Cleanup
End Sub
Классы для оптимизации:AppStateSaver.clsvba



Option Explicit

Private m_calc As XlCalculation
Private m_screen As Boolean
Private m_events As Boolean
Private m_statusBar As Boolean
Private m_alerts As Boolean

Public Sub SaveAndDisable()
    With Application
        m_calc = .Calculation
        m_screen = .ScreenUpdating
        m_events = .EnableEvents
        m_statusBar = .DisplayStatusBar
        m_alerts = .DisplayAlerts
        
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayStatusBar = False
        .DisplayAlerts = False
    End With
End Sub

Public Sub Restore()
    With Application
        .Calculation = m_calc
        .ScreenUpdating = m_screen
        .EnableEvents = m_events
        .DisplayStatusBar = m_statusBar
        .DisplayAlerts = m_alerts
    End With
End Sub
Что даст наибольший эффект на ноутбуке:Отключение ScreenUpdating и Calculation - даст 20-30% ускоренияКэширование файлов - уберет многократное открытие/закрытиеЗамена PowerQuery - может дать до 50% ускорения в modBarCodePreventSleep - предотвратит снижение частоты CPUРекомендую начать с:Добавить AppStateSaver в начале и конце main_subРеализовать кэширование файловЗаменить PowerQuery на обычную обработку в modBarCodeПосле этих изменений разница между активным и фоновым режимом должна уменьшиться.Хотите, чтобы я подробнее разобрал конкретный модуль или помог реализовать какую-то из оптимизаций?
     
     
     
    #6
    12.12.2025 13:35:05
    Код
    Ключевые оптимизации:
1. Кэширование файлов. Все файлы открываются один раз и кэшируются.
Убрано многократное открытие/закрытие
2. Замена PowerQuery на словари. Убрана зависимость от PowerQuery в обработке штрихкодов.
Используются быстрые словари Scripting.Dictionary
3. Оптимизация работы с Excel. Отключены все обновления экрана и расчеты.
Используются быстрые методы работы с массивами.
Минимизировано обращение к ячейкам через Range.Value
4. Приоритеты и управление питанием. Повышен приоритет потока Excel.
Предотвращен переход в спящий режим.
Привязка к производительным ядрам на гибридных процессорах
5. Пакетная обработка. Объединены операции со словарями.
Убраны лишние циклы. Используются быстрые алгоритмы копирования
6. Легкий DoEvents.
Добавлен облегченный DoEvents для отзывчивости без потерь производительности.
Использование: Замените старые модули на новые.
Для запуска используйте RunOptimized из modMainEntry
Настройте привязку к ядрам под свою архитектуру процессора.
Эта версия должна работать значительно быстрее на ноутбуке, особенно в фоновом режиме.

1. modGlobals - остается без изменений

Option Explicit
Public strPath As String 'путь к папке
Public Enum eFixed_Column ' столбцы для заполнения в шаблоне
    otd = 2
    dep
    gr
    podgr
    art
    naim
    Post
    prod
    kod
    resident
    shtrih
    price_val
    last_price
    margin
    avg_price
    grpABC
    revenue
    avg_margin
    gmroi
    column_to_fill = 68
    last_column = 93
End Enum

Public Enum eFixed_Row
    row_to_fill = 7
End Enum

2. clsAppOptimizer - новый класс для оптимизации

' clsAppOptimizer
Option Explicit

Private Type TAppSettings
    ScreenUpdating As Boolean
    Calculation As XlCalculation
    EnableEvents As Boolean
    DisplayAlerts As Boolean
    DisplayStatusBar As Boolean
    PrintCommunication As Boolean
    PreviousPriority As Long
End Type

Private this As TAppSettings
Private Declare PtrSafe Function SetThreadPriority Lib "kernel32" (ByVal hThread As LongPtr, ByVal nPriority As Long) As Long
Private Declare PtrSafe Function GetCurrentThread Lib "kernel32" () As LongPtr
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function SetThreadExecutionState Lib "kernel32" (ByVal esFlags As Long) As Long

Private Const THREAD_PRIORITY_HIGHEST = 2
Private Const THREAD_PRIORITY_NORMAL = 0
Private Const ES_SYSTEM_REQUIRED As Long = &H1
Private Const ES_CONTINUOUS As Long = &H80000000

Public Sub OptimizeStart()
    ' Сохраняем текущие настройки
    With Application
        this.ScreenUpdating = .ScreenUpdating
        this.Calculation = .Calculation
        this.EnableEvents = .EnableEvents
        this.DisplayAlerts = .DisplayAlerts
        this.DisplayStatusBar = .DisplayStatusBar
        this.PrintCommunication = .PrintCommunication
        
        ' Устанавливаем высокопроизводительные настройки
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
        .DisplayStatusBar = False
        .PrintCommunication = False
    End With
    
    ' Повышаем приоритет потока
    Dim hThread As LongPtr
    hThread = GetCurrentThread()
    this.PreviousPriority = SetThreadPriority(hThread, THREAD_PRIORITY_HIGHEST)
    
    ' Предотвращаем сон системы
    SetThreadExecutionState ES_CONTINUOUS Or ES_SYSTEM_REQUIRED
End Sub

Public Sub OptimizeEnd()
    ' Восстанавливаем настройки
    With Application
        .ScreenUpdating = this.ScreenUpdating
        .Calculation = this.Calculation
        .EnableEvents = this.EnableEvents
        .DisplayAlerts = this.DisplayAlerts
        .DisplayStatusBar = this.DisplayStatusBar
        .PrintCommunication = this.PrintCommunication
    End With
    
    ' Восстанавливаем приоритет потока
    Dim hThread As LongPtr
    hThread = GetCurrentThread()
    SetThreadPriority(hThread, this.PreviousPriority)
    
    ' Разрешаем сон системы
    SetThreadExecutionState ES_CONTINUOUS
End Sub

Public Sub DoEventsLight()
    ' Облегченная версия DoEvents для фонового режима
    Static lastTime As Double
    If Timer - lastTime > 0.1 Then ' Только каждые 0.1 секунды
        DoEvents
        lastTime = Timer
    End If
End Sub

3. clsFileCache - кэширование файлов

' clsFileCache
Option Explicit

Private fileCache As Object
Private wbCache As Object

Private Sub Class_Initialize()
    Set fileCache = CreateObject("Scripting.Dictionary")
    Set wbCache = CreateObject("Scripting.Dictionary")
End Sub

Private Sub Class_Terminate()
    CloseAll
    Set fileCache = Nothing
    Set wbCache = Nothing
End Sub

Public Function GetWorkbook(ByVal fullPath As String) As Workbook
    If Not wbCache.Exists(fullPath) Then
        Dim wb As Workbook
        Set wb = Workbooks.Open(fullPath, ReadOnly:=True, UpdateLinks:=0, _
                                IgnoreReadOnlyRecommended:=True, CorruptLoad:=xlNormalLoad)
        wbCache.Add fullPath, wb
        Set GetWorkbook = wb
    Else
        Set GetWorkbook = wbCache(fullPath)
    End If
End Function

Public Function FileExists(ByVal fullPath As String) As Boolean
    If Not fileCache.Exists(fullPath) Then
        fileCache.Add fullPath, (Dir(fullPath) <> "")
    End If
    FileExists = fileCache(fullPath)
End Function

Public Sub CloseAll()
    Dim key As Variant
    For Each key In wbCache.Keys
        On Error Resume Next
        wbCache(key).Close SaveChanges:=False
    Next key
    wbCache.RemoveAll
End Sub

4. clstSheetTransformationFast - оптимизированная версия

' clstSheetTransformationFast
Option Explicit

Private m_current_sh As Worksheet
Private m_appOpt As clsAppOptimizer
Private Const m_max_length_name As Long = 30

Public Property Get current_sheet() As Worksheet
    Set current_sheet = m_current_sh
End Property

Public Property Set current_sheet(ByVal vNewValue As Worksheet)
    Set m_current_sh = vNewValue
    Set m_appOpt = New clsAppOptimizer
End Property

Public Sub unmerge_used_range()
    If Not m_current_sh Is Nothing Then
        m_current_sh.UsedRange.UnMerge
    End If
End Sub

Public Sub Delete_Empty_Rows_Fast()
    ' Быстрое удаление пустых строк
    If m_current_sh Is Nothing Then Exit Sub
    
    Dim lastRow As Long
    lastRow = m_current_sh.Cells(m_current_sh.Rows.Count, 1).End(xlUp).Row
    
    If lastRow > 1000 Then
        ' Для больших листов используем более быстрый метод
        Dim data As Variant
        Dim r As Long, startDel As Long, endDel As Long
        Dim inEmptyBlock As Boolean
        
        data = m_current_sh.Range("A1:A" & lastRow).Value
        
        For r = 1 To lastRow
            If Len(Trim(CStr(data(r, 1)))) = 0 And _
               Application.CountA(m_current_sh.Rows(r)) = 0 Then
                If Not inEmptyBlock Then
                    startDel = r
                    inEmptyBlock = True
                End If
            Else
                If inEmptyBlock Then
                    endDel = r - 1
                    If endDel >= startDel Then
                        m_current_sh.Rows(startDel & ":" & endDel).Delete
                        r = startDel - 1
                        lastRow = lastRow - (endDel - startDel + 1)
                        ReDim Preserve data(1 To lastRow, 1 To 1)
                    End If
                    inEmptyBlock = False
                End If
            End If
        Next r
    Else
        ' Для маленьких листов - стандартный метод
        Dim i As Long
        For i = lastRow To 1 Step -1
            If Application.CountA(m_current_sh.Rows(i)) = 0 Then
                m_current_sh.Rows(i).Delete
            End If
        Next i
    End If
End Sub

Public Function Get_Last_Row() As Long
    Get_Last_Row = m_current_sh.Cells(m_current_sh.Rows.Count, 1).End(xlUp).Row
End Function

Public Function Get_Last_Column() As Long
    Get_Last_Column = m_current_sh.Cells(1, m_current_sh.Columns.Count).End(xlToLeft).Column
End Function


5. modMain - полностью оптимизированный

' modMain
Option Explicit

Type tpMrk
    market As String
    price As String
    element As Long
    base_column As Long
    price_column As Long
    price_add As String
End Type

Private fileCache As clsFileCache
Private appOptimizer As clsAppOptimizer
Private sheetTransformer As clstSheetTransformationFast

Public Sub main_sub()
    ' Инициализация оптимизаторов
    Set appOptimizer = New clsAppOptimizer
    Set fileCache = New clsFileCache
    Set sheetTransformer = New clstSheetTransformationFast
    
    ' Запуск оптимизации
    appOptimizer.OptimizeStart
    
    On Error GoTo ErrorHandler
    
    ' Получаем путь
    strPath = ThisWorkbook.Path
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    
    ' Читаем параметры
    Dim mrk As tpMrk
    With mrk
        .market = ThisWorkbook.Worksheets(1).Range("A18").Value
        .price = ThisWorkbook.Worksheets(1).Range("B18").Value
        .element = ThisWorkbook.Worksheets(1).Range("C18").Value
        .base_column = Choose(.element, 1, eFixed_Column.art, eFixed_Column.kod)
        .price_column = Choose(.element, 0, 1, 0)
        .price_add = Choose(.element, "MLT", .market, IIf(.market = "LGN", .market, "MLT"))
    End With
    
    ' Таймер
    Dim clsTim As clsTimer
    Set clsTim = New clsTimer
    clsTim.start_timer
    
    ' Открываем шаблон
    Dim shablon As Workbook
    Set shablon = fileCache.GetWorkbook(strPath & "шаблон.xlsm")
    Dim ws_shablon As Worksheet
    Set ws_shablon = shablon.Worksheets(1)
    Set sheetTransformer.current_sheet = ws_shablon
    
    clsTim.fix_timer "открытие файла Шаблон"
    
    ' Загрузка данных продаж (1)
    Dim tmp_arr As Variant, order_arr As Variant
    GetDataSalesFast strPath, tmp_arr, 1
    
    clsTim.fix_timer "заполнение массива продажи(1)")
    
    ' Создаем массив заказов
    ReDim order_arr(LBound(tmp_arr, 1) To UBound(tmp_arr, 1), 1 To 1)
    FastCopyColumn tmp_arr, order_arr, 1, 1
    
    ' Получаем индексы колонок
    Dim arr_ind As Variant
    arr_ind = GetArrIndices(UBound(tmp_arr, 2), mrk.element)
    
    If mrk.element = 2 Then
        arr_ind = CombineArrays(Array(eFixed_Column.art, eFixed_Column.naim), arr_ind)
    Else
        arr_ind = CombineArrays(Array(eFixed_Column.kod, eFixed_Column.art, eFixed_Column.naim), arr_ind)
    End If
    
    ' Заполняем шаблон
    FillShablonFast ws_shablon, arr_ind, tmp_arr, True
    ws_shablon.Calculate
    
    clsTim.fix_timer "печать массива продажи(1)")
    
    ' Удаляем лишние строки
    Dim lastRow As Long
    lastRow = ws_shablon.Cells(ws_shablon.Rows.Count, mrk.base_column).End(xlUp).Row
    ws_shablon.Range(ws_shablon.Cells(lastRow + 1, mrk.base_column), _
                     ws_shablon.Cells(ws_shablon.Rows.Count, mrk.base_column)).EntireRow.Delete
    
    ' Конвертируем в значения
    ConvertToValuesFast ws_shablon.Range(ws_shablon.Cells(eFixed_Row.row_to_fill, eFixed_Column.otd), _
                                         ws_shablon.Cells(lastRow, eFixed_Column.last_column))
    
    clsTim.fix_timer "удаление лишних строк в Шаблоне"
    
    ' Загрузка остальных данных (оптимизированная)
    ProcessAllDataFast ws_shablon, order_arr, strPath, mrk, lastRow, clsTim
    
    ' Закрываем все файлы
    fileCache.CloseAll
    
    ' Восстанавливаем настройки
    appOptimizer.OptimizeEnd
    
    ' Показываем результаты
    MsgBox clsTim.print_result
    
    Exit Sub
    
ErrorHandler:
    ' Очистка при ошибке
    On Error Resume Next
    fileCache.CloseAll
    appOptimizer.OptimizeEnd
    MsgBox "Ошибка: " & Err.Description, vbCritical
End Sub

Private Sub ProcessAllDataFast(ws As Worksheet, order_arr As Variant, path As String, _
                               mrk As tpMrk, lastRow As Long, clsTim As clsTimer)
    ' Объединенная обработка всех данных
    Dim tmp_arr As Variant
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = TextCompare
    
    ' Обработка продаж (2)
    GetDataSalesFast path, tmp_arr, 2
    clsTim.fix_timer "заполнение массива продажи(2)")
    
    RemovePostsFast tmp_arr
    clsTim.fix_timer "очистка массива продажи(2)")
    
    Dim out_arr As Variant
    ReDim out_arr(LBound(order_arr, 1) To UBound(order_arr, 1), 1 To 5)
    Dim arr_ind2(1 To 5) As Variant
    arr_ind2(1) = eFixed_Column.Post
    arr_ind2(2) = eFixed_Column.avg_price
    arr_ind2(3) = eFixed_Column.revenue
    arr_ind2(4) = eFixed_Column.avg_margin
    arr_ind2(5) = eFixed_Column.last_price
    
    FillDictPostFast tmp_arr, dict, 2, True
    DictToArrayFast out_arr, order_arr, dict, 1
    dict.RemoveAll
    
    clsTim.fix_timer "подготовка массива продажи(2)"
    
    ' Продажи (3)
    GetDataSalesFast path, tmp_arr, 3
    clsTim.fix_timer "заполнение массива продажи(3)"
    
    Dim i As Long
    For i = LBound(tmp_arr, 2) + 1 To UBound(tmp_arr, 2)
        FillDictPostFast tmp_arr, dict, i, False
        DictToArrayFast out_arr, order_arr, dict, i - LBound(tmp_arr, 2) + 1
        dict.RemoveAll
        appOptimizer.DoEventsLight
    Next i
    
    clsTim.fix_timer "подготовка массива продажи(3)"
    
    FillShablonFast ws, arr_ind2, out_arr, True
    clsTim.fix_timer "печать массива продажи(2-3)"
    
    ' Прайс
    GetDataPriceFast path, tmp_arr, mrk.price, mrk.price_column
    clsTim.fix_timer "заполнение массива Прайс"
    
    ReDim out_arr(LBound(order_arr, 1) To UBound(order_arr, 1), 1 To 1)
    ReDim arr_ind2(1 To 1)
    arr_ind2(1) = eFixed_Column.price_val
    
    FillDictPostFast tmp_arr, dict, UBound(tmp_arr, 2), False
    DictToArrayFast out_arr, order_arr, dict, 1
    dict.RemoveAll
    
    clsTim.fix_timer "подготовка массива Прайс"
    
    FillShablonFast ws, arr_ind2, out_arr, True
    clsTim.fix_timer "печать массива Прайс"
    
    ' Структура
    GetDataStructureFast path, tmp_arr, mrk.price_add, mrk.price_column
    clsTim.fix_timer "заполнение массива Структура"
    
    ReDim out_arr(LBound(order_arr, 1) To UBound(order_arr, 1), 1 To 6)
    ReDim arr_ind2(1 To 6)
    arr_ind2(1) = eFixed_Column.prod
    arr_ind2(2) = eFixed_Column.otd
    arr_ind2(3) = eFixed_Column.dep
    arr_ind2(4) = eFixed_Column.gr
    arr_ind2(5) = eFixed_Column.podgr
    arr_ind2(6) = eFixed_Column.resident
    
    Dim k As Long: k = 1
    For i = LBound(tmp_arr, 2) + (3 - mrk.price_column) To UBound(tmp_arr, 2)
        FillDictPostFast tmp_arr, dict, i, False
        DictToArrayFast out_arr, order_arr, dict, k
        k = k + 1
        dict.RemoveAll
        appOptimizer.DoEventsLight
    Next i
    
    clsTim.fix_timer "подготовка массива Структура"
    FillShablonFast ws, arr_ind2, out_arr, True
    clsTim.fix_timer "печать массива Структура"
    
    ' Штрихкод (оптимизированная версия без PowerQuery)
    GetDataBarcodeFast path, tmp_arr, (mrk.price_column + 1)
    clsTim.fix_timer "заполнение массива Штрихкод"
    
    ReDim out_arr(LBound(order_arr, 1) To UBound(order_arr, 1), 1 To 1)
    ReDim arr_ind2(1 To 1)
    arr_ind2(1) = eFixed_Column.shtrih
    
    FillDictPostFast tmp_arr, dict, UBound(tmp_arr, 2), False
    DictToArrayFast out_arr, order_arr, dict, 1
    dict.RemoveAll
    
    clsTim.fix_timer "подготовка массива Штрихкод"
    FillShablonFast ws, arr_ind2, out_arr, True
    clsTim.fix_timer "печать массива Штрихкод"
    
    ' Финал
    ProcessFinalCalculations ws, lastRow, path, mrk.price_column, clsTim
End Sub

Private Sub ProcessFinalCalculations(ws As Worksheet, lastRow As Long, path As String, _
                                     price_column As Long, clsTim As clsTimer)
    With ws
        ' Обработка формул и проверок
        ProcessFormulasAndChecks ws, lastRow
        clsTim.fix_timer "обработка формул и проверок"
        
        ' Остатки
        Dim tmp_arr As Variant, dict As Object
        Set dict = CreateObject("Scripting.Dictionary")
        GetDataOstatkiFast path, tmp_arr, price_column
        FillDictPostFast tmp_arr, dict, UBound(tmp_arr, 2), False, True
        
        Dim base_arr As Variant, lastCol_arr As Variant
        base_arr = .Range(.Cells(eFixed_Row.row_to_fill, 1), _
                          .Cells(lastRow, 1)).Value
        lastCol_arr = .Range(.Cells(eFixed_Row.row_to_fill, eFixed_Column.column_to_fill - 1), _
                             .Cells(lastRow, eFixed_Column.column_to_fill)).Value
        
        Dim counter As Long, ost_val As Double, sum_val As Double, price_val As Double
        For counter = LBound(base_arr, 1) To UBound(base_arr, 1)
            If dict.Exists(base_arr(counter, 1)) Then
                ost_val = lastCol_arr(counter, 1)
                sum_val = lastCol_arr(counter, 2)
                If ost_val <> dict(base_arr(counter, 1)) Then
                    If ost_val <> 0 Then
                        price_val = Abs(sum_val / ost_val)
                        ost_val = dict(base_arr(counter, 1))
                        sum_val = ost_val * price_val
                    Else
                        sum_val = 0
                    End If
                    lastCol_arr(counter, 1) = ost_val
                    lastCol_arr(counter, 2) = sum_val
                End If
                If lastCol_arr(counter, 2) < 0 Then
                    lastCol_arr(counter, 2) = 0
                End If
            Else
                lastCol_arr(counter, 1) = 0
                lastCol_arr(counter, 2) = 0
            End If
            If counter Mod 100 = 0 Then appOptimizer.DoEventsLight
        Next counter
        
        .Range(.Cells(eFixed_Row.row_to_fill, eFixed_Column.column_to_fill - 1), _
               .Cells(lastRow, eFixed_Column.column_to_fill)).Value = lastCol_arr
        clsTim.fix_timer "проверка остатков"
        clsTim.end_timer
    End With
End Sub

' Быстрые вспомогательные функции
Private Sub FastCopyColumn(ByRef srcArr As Variant, ByRef destArr As Variant, _
                           ByVal srcCol As Long, ByVal destCol As Long)
    Dim i As Long
    For i = LBound(srcArr, 1) To UBound(srcArr, 1)
        destArr(i, destCol) = srcArr(i, srcCol)
    Next i
End Sub

Private Sub FillShablonFast(ByVal ws As Worksheet, ByVal arr_column As Variant, _
                           ByVal arr_data As Variant, ByVal bFlag As Boolean)
    Dim i As Long
    For i = UBound(arr_column, 1) To LBound(arr_column, 1) Step -1
        If i = LBound(arr_column, 1) Then
            If bFlag Then
                ws.Cells(eFixed_Row.row_to_fill, arr_column(i)).Resize(UBound(arr_data, 1), 1).Value = _
                    Application.Index(arr_data, 0, i)
            End If
        Else
            ws.Cells(eFixed_Row.row_to_fill, arr_column(i)).Resize(UBound(arr_data, 1), 1).Value = _
                Application.Index(arr_data, 0, i)
        End If
    Next i
End Sub

Private Function GetArrIndices(ByVal ind As Long, ByVal fixed_num As Long) As Variant
    Dim num_of_col As Long: num_of_col = ind - fixed_num
    Dim arr() As Variant: ReDim arr(1 To num_of_col)
    Dim n As Long: n = eFixed_Column.column_to_fill
    
    Dim i As Long
    For i = num_of_col To 1 Step -1
        arr(i) = n
        n = n - 1
    Next i
    
    GetArrIndices = arr
End Function

Private Function CombineArrays(ByVal arr1 As Variant, ByVal arr2 As Variant) As Variant
    Dim tmp As String
    tmp = Join(Array(Join(arr1, "-"), Join(arr2, "-")), "-")
    Dim comb As Variant, el As Variant, i As Long
    comb = Split(tmp, "-")
    ReDim new_arr(1 To UBound(comb) + 1) As Long
    For Each el In comb
        i = i + 1
        new_arr(i) = CLng(el)
    Next el
    CombineArrays = new_arr
End Function

Private Sub ConvertToValuesFast(ByRef rng As Range)
    Dim arr As Variant
    arr = rng.Value
    rng.Value = arr
End Sub

Private Sub FillDictPostFast(ByVal arr As Variant, ByRef dict As Object, _
                            ByVal ind As Long, ByVal bFlag As Boolean, _
                            Optional ByVal bSum As Boolean = False)
    Dim i As Long, bExists As Boolean
    For i = LBound(arr, 1) To UBound(arr, 1)
        If Len(arr(i, ind)) Then
            If Not bSum Then
                If bFlag Then
                    If dict.Exists(arr(i, 1)) Then
                        dict(arr(i, 1)) = dict(arr(i, 1)) & ", " & arr(i, ind)
                    Else
                        dict(arr(i, 1)) = arr(i, ind)
                    End If
                Else
                    dict(arr(i, 1)) = arr(i, ind)
                End If
            Else
                dict(arr(i, 1)) = dict(arr(i, 1)) + arr(i, ind)
            End If
        End If
        If i Mod 1000 = 0 Then appOptimizer.DoEventsLight
    Next i
End Sub

Private Sub DictToArrayFast(ByRef arr_data As Variant, ByVal arr_order As Variant, _
                           ByRef dict As Object, ByVal ind As Long)
    Dim i As Long
    For i = LBound(arr_order, 1) To UBound(arr_order, 1)
        arr_data(i, ind) = dict(arr_order(i, 1))
    Next i
End Sub

Private Sub RemovePostsFast(ByRef arr As Variant)
    Const adrCell As String = "G1"
    Dim rng As Range
    Set rng = ThisWorkbook.Worksheets(1).Range(adrCell).CurrentRegion
    
    Dim arr_clean As Variant
    arr_clean = rng.Offset(1).Resize(rng.Rows.Count - 1).Value
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim j As Long
    For j = LBound(arr_clean, 1) To UBound(arr_clean, 1)
        dict(arr_clean(j, 1)) = Empty
    Next j
        
    Dim i As Long
    For i = LBound(arr, 1) To UBound(arr, 1)
        If dict.Exists(arr(i, 2)) Then
            arr(i, 2) = vbNullString
        End If
    Next i
End Sub

Private Sub ProcessFormulasAndChecks(ws As Worksheet, lastRow As Long)
    ' Оптимизированная обработка формул
    With ws
        ' Обработка последней цены
        Dim tmp_arr As Variant, counter As Long, tmp_value As Variant
        
        With .Range(.Cells(eFixed_Row.row_to_fill, eFixed_Column.last_price), _
                   .Cells(lastRow, eFixed_Column.last_price))
            tmp_arr = .Value
            For counter = LBound(tmp_arr, 1) To UBound(tmp_arr, 1)
                tmp_value = tmp_arr(counter, 1)
                If Not IsEmpty(tmp_value) Then
                    If tmp_value <= 0 Then
                        tmp_arr(counter, 1) = Empty
                    End If
                End If
            Next counter
            .Value = tmp_arr
            Erase tmp_arr
        End With
        
        ' Маржа
        With .Range(.Cells(eFixed_Row.row_to_fill, eFixed_Column.margin), _
                   .Cells(lastRow, eFixed_Column.margin))
            .Formula2R1C1Local = "=ЕСЛИ(ЕПУСТО(RC[-1]);"""";ЕСЛИОШИБКА((RC[-2]-RC[-1])/RC[-2];""""))"
            .Calculate
            .Value = .Value
        End With
        
        ' Средняя цена
        With .Range(.Cells(eFixed_Row.row_to_fill, eFixed_Column.avg_price), _
                   .Cells(lastRow, eFixed_Column.avg_price))
            tmp_arr = .Value
            For counter = LBound(tmp_arr, 1) To UBound(tmp_arr, 1)
                tmp_value = tmp_arr(counter, 1)
                If Not IsEmpty(tmp_value) Then
                    If tmp_value <= 0 Then
                        tmp_arr(counter, 1) = Empty
                    End If
                End If
            Next counter
            .Value = tmp_arr
            Erase tmp_arr
        End With
        
        ' Средняя маржа
        With .Range(.Cells(eFixed_Row.row_to_fill, eFixed_Column.avg_margin), _
                   .Cells(lastRow, eFixed_Column.avg_margin))
            tmp_arr = .Value
            For counter = LBound(tmp_arr, 1) To UBound(tmp_arr, 1)
                tmp_value = tmp_arr(counter, 1)
                If Not IsEmpty(tmp_value) Then
                    Select Case tmp_value
                        Case -10 To 10
                        Case Else
                            tmp_arr(counter, 1) = Empty
                    End Select
                End If
            Next counter
            .Value = tmp_arr
            Erase tmp_arr
        End With
        
        ' GMROI
        With .Range(.Cells(eFixed_Row.row_to_fill, eFixed_Column.gmroi), _
                   .Cells(lastRow, eFixed_Column.gmroi))
            tmp_arr = .Value
            For counter = LBound(tmp_arr, 1) To UBound(tmp_arr, 1)
                tmp_value = tmp_arr(counter, 1)
                If Not IsEmpty(tmp_value) Then
                    Select Case tmp_value
                        Case -10 To 10
                        Case Else
                            tmp_arr(counter, 1) = Empty
                    End Select
                End If
            Next counter
            .Value = tmp_arr
            Erase tmp_arr
        End With
    End With
End Sub

6. modDataLoadersFast - оптимизированные загрузчики данных

' modDataLoadersFast
Option Explicit

Private fileCache As New clsFileCache
Private appOptimizer As New clsAppOptimizer

Public Sub GetDataSalesFast(ByVal path As String, ByRef arr As Variant, ByVal sh_ind As Long)
    Const strName As String = "продажи.xlsx"
    Dim fullPath As String: fullPath = path & strName
    
    If fileCache.FileExists(fullPath) Then
        Dim wb As Workbook: Set wb = fileCache.GetWorkbook(fullPath)
        Dim ws As Worksheet: Set ws = wb.Worksheets(sh_ind)
        
        CleanSheetFast ws
        
        Dim lastRow As Long, lastCol As Long
        lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        
        Select Case sh_ind
            Case 1
                arr = ws.Range(ws.Cells(8, 1), ws.Cells(lastRow, lastCol - 4)).Value
            Case 2
                arr = ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, lastCol)).Value
            Case 3
                ws.Range("B1", ws.Cells(1, lastCol - 4)).EntireColumn.Delete
                lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
                lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
                arr = ws.Range(ws.Cells(8, 1), ws.Cells(lastRow, lastCol)).Value
        End Select
    Else
        MsgBox "Файла не существует: " & fullPath, vbExclamation
    End If
End Sub

Public Sub GetDataPriceFast(ByVal path As String, ByRef arr As Variant, _
                           ByVal strPrice As String, ByVal start_col As Long)
    Const strName As String = "прайс.xlsx"
    Dim fullPath As String: fullPath = path & strName
    
    If fileCache.FileExists(fullPath) Then
        Dim wb As Workbook: Set wb = fileCache.GetWorkbook(fullPath)
        Dim ws As Worksheet: Set ws = wb.Worksheets(1)
        
        CleanSheetFast ws
        
        arr = TransformPriceFast(strPrice, ws, start_col)
    Else
        MsgBox "Файла не существует: " & fullPath, vbExclamation
    End If
End Sub

Public Sub GetDataStructureFast(ByVal path As String, ByRef arr As Variant, _
                               ByVal strMarket As String, ByVal start_col As Long)
    Const strName As String = "Структура.xlsx"
    Dim fullPath As String: fullPath = path & strName
    
    If fileCache.FileExists(fullPath) Then
        Dim wb As Workbook: Set wb = fileCache.GetWorkbook(fullPath)
        Dim ws As Worksheet: Set ws = wb.Worksheets(1)
        
        CleanSheetFast ws
        
        arr = TransformStructureFast(strMarket, ws, start_col)
    Else
        MsgBox "Файла не существует: " & fullPath, vbExclamation
    End If
End Sub

Public Sub GetDataBarcodeFast(ByVal path As String, ByRef arr As Variant, ByVal start_col As Long)
    Const strName As String = "штрихкод.xlsx"
    Dim fullPath As String: fullPath = path & strName
    
    If fileCache.FileExists(fullPath) Then
        Dim wb As Workbook: Set wb = fileCache.GetWorkbook(fullPath)
        Dim ws As Worksheet: Set ws = wb.Worksheets(1)
        
        arr = ProcessBarcodeFast(ws, start_col)
    Else
        MsgBox "Файла не существует: " & fullPath, vbExclamation
    End If
End Sub

Public Sub GetDataOstatkiFast(ByVal path As String, ByRef arr As Variant, ByVal start_col As Long)
    Const strName As String = "остатки.xlsx"
    Dim fullPath As String: fullPath = path & strName
    
    If fileCache.FileExists(fullPath) Then
        Dim wb As Workbook: Set wb = fileCache.GetWorkbook(fullPath)
        Dim ws As Worksheet: Set ws = wb.Worksheets(1)
        
        arr = TransformOstatkiFast(ws, start_col)
    Else
        MsgBox "Файла не существует: " & fullPath, vbExclamation
    End If
End Sub

Private Function TransformPriceFast(ByVal strPrice As String, ByVal ws As Worksheet, _
                                   ByVal start_col As Long) As Variant
    Const Price_Name As String = "Вид цены"
    
    Dim lastRow As Long, lastCol As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    ' Находим столбец с ценой
    Dim priceCol As Long, r As Long, c As Long
    For c = 1 To lastCol
        If ws.Cells(1, c).Value = Price_Name Then
            priceCol = c
            Exit For
        End If
    Next c
    
    If priceCol = 0 Then Exit Function
    
    ' Фильтруем данные без AdvancedFilter
    Dim sourceData As Variant
    sourceData = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol)).Value
    
    Dim resultList As Object
    Set resultList = CreateObject("System.Collections.ArrayList")
    
    For r = 2 To lastRow
        If sourceData(r, priceCol) = strPrice Then
            resultList.Add r
        End If
    Next r
    
    If resultList.Count > 0 Then
        ReDim result(1 To resultList.Count, 1 To lastCol - start_col)
        Dim i As Long, j As Long
        For i = 1 To resultList.Count
            For j = start_col + 1 To lastCol
                result(i, j - start_col) = sourceData(resultList(i - 1), j)
            Next j
        Next i
        TransformPriceFast = result
    End If
End Function

Private Function TransformStructureFast(ByVal strMarket As String, ByVal ws As Worksheet, _
                                       ByVal start_col As Long) As Variant
    Const Price_Name As String = "Привязка"
    
    Dim lastRow As Long, lastCol As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    ' Замена KHS на MLT
    Dim c As Long
    For c = 1 To lastCol
        If ws.Cells(1, c).Value Like "*KHS*" Then
            Dim r As Long
            For r = 2 To lastRow
                If ws.Cells(r, c).Value = "KHS" Then
                    ws.Cells(r, c).Value = "MLT"
                End If
            Next r
        End If
    Next c
    
    ' Находим столбец с привязкой
    Dim bindCol As Long
    For c = 1 To lastCol
        If ws.Cells(1, c).Value = Price_Name Then
            bindCol = c
            Exit For
        End If
    Next c
    
    If bindCol = 0 Then Exit Function
    
    ' Фильтруем данные
    Dim sourceData As Variant
    sourceData = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol)).Value
    
    Dim resultList As Object
    Set resultList = CreateObject("System.Collections.ArrayList")
    
    For r = 2 To lastRow
        If sourceData(r, bindCol) = strMarket Then
            resultList.Add r
        End If
    Next r
    
    If resultList.Count > 0 Then
        ReDim result(1 To resultList.Count, 1 To lastCol - (start_col + 1))
        Dim i As Long, j As Long
        For i = 1 To resultList.Count
            For j = start_col + 1 To lastCol - 1
                result(i, j - start_col) = sourceData(resultList(i - 1), j)
            Next j
        Next i
        TransformStructureFast = result
    End If
End Function

Private Function ProcessBarcodeFast(ByVal ws As Worksheet, ByVal num_art As Long) As Variant
    Dim lastRow As Long, lastCol As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    ' Находим столбцы
    Dim codeCol As Long, barcodeCol As Long
    Dim c As Long
    For c = 1 To lastCol
        Dim header As String
        header = CStr(ws.Cells(1, c).Value)
        
        If num_art = 1 And InStr(1, header, "Код", vbTextCompare) > 0 Then
            codeCol = c
        ElseIf num_art = 2 And InStr(1, header, "Артикул", vbTextCompare) > 0 Then
            codeCol = c
        End If
        
        If InStr(1, header, "Штрихкод", vbTextCompare) > 0 Then
            barcodeCol = c
        End If
    Next c
    
    If codeCol = 0 Or barcodeCol = 0 Then Exit Function
    
    ' Читаем данные
    Dim data As Variant
    data = ws.Range(ws.Cells(2, codeCol), ws.Cells(lastRow, barcodeCol)).Value
    
    ' Агрегируем через словарь
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = TextCompare
    
    Dim i As Long
    For i = 1 To UBound(data, 1)
        Dim key As String: key = Trim(CStr(data(i, 1)))
        Dim barcode As String: barcode = Trim(CStr(data(i, 2)))
        
        If Len(key) > 0 Then
            If Not dict.Exists(key) Then
                dict.Add key, barcode
            ElseIf Len(barcode) > 0 Then
                dict(key) = dict(key) & ", " & barcode
            End If
        End If
    Next i
    
    ' Конвертируем в массив
    ReDim result(1 To dict.Count, 1 To 2)
    i = 1
    Dim k As Variant
    For Each k In dict.Keys
        result(i, 1) = k
        result(i, 2) = dict(k)
        i = i + 1
    Next k
    
    ProcessBarcodeFast = result
End Function

Private Function TransformOstatkiFast(ByVal ws As Worksheet, ByVal start_col As Long) As Variant
    Const findHeader As String = "Номенклатура.Код"
    
    CleanSheetFast ws
    
    Dim lastRow As Long, lastCol As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    ' Находим заголовок
    Dim headerRow As Long
    Dim r As Long, c As Long
    For r = 1 To lastRow
        For c = 1 To lastCol
            If ws.Cells(r, c).Value = findHeader Then
                headerRow = r
                Exit For
            End If
        Next c
        If headerRow > 0 Then Exit For
    Next r
    
    If headerRow = 0 Then Exit Function
    
    ' Удаляем строки выше заголовка
    If headerRow > 1 Then
        ws.Rows("1:" & (headerRow - 1)).Delete
        lastRow = lastRow - (headerRow - 1)
    End If
    
    ' Читаем данные
    Dim data As Variant
    data = ws.Range(ws.Cells(2, start_col + 1), ws.Cells(lastRow, lastCol)).Value
    
    TransformOstatkiFast = data
End Function

Private Sub CleanSheetFast(ByVal sh As Worksheet)
    Dim lastRow As Long, lastCol As Long
    lastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
    lastCol = sh.Cells(1, sh.Columns.Count).End(xlToLeft).Column
    
    ' Быстрое удаление полностью пустых строк
    Dim r As Long
    For r = lastRow To 1 Step -1
        If Application.CountA(sh.Rows(r)) = 0 Then
            sh.Rows(r).Delete
        End If
    Next r
    
    ' Быстрое удаление полностью пустых столбцов
    Dim c As Long
    For c = lastCol To 1 Step -1
        If Application.CountA(sh.Columns(c)) = 0 Then
            sh.Columns(c).Delete
        End If
    Next c
End Sub


7. clsTimerFast - оптимизированный таймер

' clsTimerFast
Option Explicit

Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long

Private startTime As Currency
Private freq As Currency
Private timePoints As Object
Private pointNames As Object

Private Sub Class_Initialize()
    QueryPerformanceFrequency freq
    Set timePoints = CreateObject("Scripting.Dictionary")
    Set pointNames = CreateObject("Scripting.Dictionary")
End Sub

Public Sub Start()
    QueryPerformanceCounter startTime
    timePoints.RemoveAll
    pointNames.RemoveAll
    AddPoint "start"
End Sub

Public Sub AddPoint(ByVal pointName As String)
    Dim currentTime As Currency
    QueryPerformanceCounter currentTime
    timePoints.Add pointName, currentTime
    pointNames.Add pointNames.Count, pointName
End Sub

Public Function GetTime(ByVal pointName As String) As Double
    If timePoints.Exists(pointName) Then
        GetTime = (timePoints(pointName) - startTime) / freq
    End If
End Function

Public Function GetReport() As String
    Dim report As String
    Dim i As Long
    Dim prevPoint As String, currPoint As String
    
    For i = 1 To pointNames.Count - 1
        prevPoint = pointNames(i - 1)
        currPoint = pointNames(i)
        report = report & currPoint & ": " & _
                Format((timePoints(currPoint) - timePoints(prevPoint)) / freq, "0.00") & " сек." & vbCrLf
    Next i
    
    report = report & "Всего: " & _
            Format((timePoints(pointNames(pointNames.Count - 1)) - startTime) / freq, "0.00") & " сек."
    
    GetReport = report
End Function

8. modMainEntry - точка входа

' modMainEntry
Option Explicit

#If Win64 Then
    Private Declare PtrSafe Function SetProcessAffinityMask Lib "kernel32" (ByVal hProcess As LongPtr, ByVal dwProcessAffinityMask As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetCurrentProcess Lib "kernel32" () As LongPtr
#Else
    Private Declare Function SetProcessAffinityMask Lib "kernel32" (ByVal hProcess As Long, ByVal dwProcessAffinityMask As Long) As Long
    Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
#End If

Public Sub RunOptimized()
    ' Привязываем процесс к производительным ядрам (для ноутбуков с гибридной архитектурой)
    #If Win64 Then
        Dim hProcess As LongPtr
        hProcess = GetCurrentProcess()
        ' Маска для первых 6 ядер (предполагаем, что это P-ядра)
        SetProcessAffinityMask hProcess, &H3F ' 0011 1111 - ядра 0-5
    #Else
        Dim hProcess As Long
        hProcess = GetCurrentProcess()
        SetProcessAffinityMask hProcess, &HF ' 1111 - ядра 0-3
    #End If
    
    ' Запускаем основной процесс
    main_sub
    
    ' Сбрасываем маску привязки
    #If Win64 Then
        SetProcessAffinityMask hProcess, &HFFFFFFFF
    #Else
        SetProcessAffinityMask hProcess, &HFFFFFFFF
    #End If
End Sub
    Изменено: Тимофеев - 12.12.2025 13:37:23
     
     
     
    #7
    12.12.2025 14:00:10
    Цитата
    Тимофеев написал:
    TransformStructureFast
    Воу-воу полехче, почему все такое "Fast" о.О ))
     
     
     
    #8
    12.12.2025 14:05:25
    вот такой он ИИ
     
     
     
    #9
    12.12.2025 14:19:46
    Цитата
    Alex написал:
    Но, думаю, не стоит тратить время на разбор чужого кода
    Могли бы и не выкладывать, а просто указать что там куча модулей и тонны кода..
    Цитата
    Тимофеев написал:
    вот такой он ИИ
    А профит в чем? Дофамин где?
     
     
     
    #10
    12.12.2025 14:32:25
    научился вставлять спойлер )
    а про профит и дофамин в соседней теме
     
     
     
    #11
    12.12.2025 14:37:44
    testuser, все равно спасибо за потраченное время.
    Тимофеев, спасибо Вам, хоть я и НЕ воспользовался кодом от ИИ, но по его комментариям увидел свои косяки, и чуть-чуть переписал свой код для ускорения :)  
    Изменено: Alex - 12.12.2025 14:56:27
     
     
     
    #12
    12.12.2025 14:44:18
    и ускорение ощутимо в итоге?
     
     
     
    #13
    12.12.2025 14:57:39
    Тимофеев, на 30 сек уменьшилось время работы макроса.
     
     
     
    #14
    12.12.2025 20:35:27
    Alex , сделайте доверенным источником папку, откуда загружается книга с макросами.
    Перезагрузите Excel и проверьте. У Вас много кода, может помочь. Если поможет - поясню.
     
     
     
    #15
    12.12.2025 22:15:18
    ZVI, добрый вечер! Спасибо Вам за участие.
    Цитата
    написал:
    Если поможет
    Не помогло.

    По советам от ИИ.
    Лучший результат, который смог получить это 212 сек со следующими настройками:
    - высокая производительность
    - в диспетчере задач приоритет реального времени
    - задал сходство: оставил работать только производительные ядра (P-cores)  
     
     
     
    #16
    12.12.2025 22:40:14
    Цитата
    Alex написал:
    Не помогло.
    Спасибо, что проверили!
    Ваш код я не смотрел.
    Обычно при таких больших временах  оптимизация кода должна дать значительное ускорение.
    Чаще всего тормозят циклы по ячейкам, или другие многократные взаимодействия между VBA и объектами Excel.
    Метод - один раз считать в массив(ы) значений диапазонов, обработать массив(ы) в VBA и присвоить результирующему диапазону массив результатов.
    Это на всякий случай. Наверное, Вы это всё знаете и используете (код я не открывал)
     
     
     
    #17
    12.12.2025 22:57:48
    ZVI, спасибо Вам за потраченное время и за советы!
    Изменено: Alex - 12.12.2025 22:58:34
     
     
     
    #18
    13.12.2025 00:14:51
    Посмотрел бегло код - все там в порядке с массивами и не только с ними.
    Так как непонятен объем данных (шаблон), то, возможные причины:
    1. Тормозят формулы, если там длинные зависимости, например, когда ячейки зависят от предыдущих, а там долгие формулы типа ВПР
    Чтобы пересчет был быстрым, бывает, что лучше в столбцах кодом вписывать формулу и сразу заменять на значения .Value=.Value
    Тогда дерево зависимостей короткое и быстрое, что может дать общий выигрыш, даже когда таких столбцов много.
    На тестовой копии можете предварительно специально (хоть вручную) заменить формулы на значения и проверить ускорение, по-сути, максимальное для данного метода. Понятно, что на результирующие данные смотреть при этом не нужно.
    2. В диапазонах можно не использовать .Calculate, т.к. формулы пересчитаются при Application.Calculation = xlCalculationAutomatic
    Это если там на этот пересчет что-нибудь не завязано, конечно.
    3. В fill_shablon() значения массива копируются в столбцы листа по одному столбцу. Если столбцов много, то это медленно. Можно подготовить результирующий (или для нескольких столбцов) массив и выгрузить его на лист. Кода будет больше, но быстрее.
    4. Словари начинают нелинейно тормозить примерно с 50000 элементов.

    В коде есть профилирование времени, интересно, какие процессы тормозят больше всего.
    Изменено: ZVI - 13.12.2025 02:56:46
     
     
     
    #19
    13.12.2025 11:48:45
    ZVI, приветствую Вас.
    Цитата
    написал:
    Так как непонятен объем данных (шаблон),
    Объем заполняемых данных около 130 тыс строк и 68 столбцов.
    В шаблоне есть немного формул, но большой цепочки зависимостей нет.
    Цитата
    написал:
    Чтобы пересчет был быстрым, бывает, что лучше в столбцах кодом вписывать формулу и сразу заменять на значения .Value=.Value
    Так обычно и делаю, чтоб минимизировать пересчеты.
    Цитата
    написал:
    В диапазонах можно не использовать .Calculate,
    Там есть зависимости, поэтому нужен пересчет.
    Цитата
    написал:
    В fill_shablon() значения массива копируются в столбцы листа по одному столбцу. Если столбцов много, то это медленно.
    Сделал это намеренно, т.к. во-первых, все копирование на лист уместилось в одну процедуру, во-вторых, есть массивы, которые копируются не в столбцы по порядку,  в разных местах листа.
    Цитата
    написал:
    4. Словари начинают нелинейно тормозить примерно с 50000 элементов.
    Спасибо за подсказку. После Вашего комментария я вспомнил, что testuser, как-то на форуме приводил сравнение коллекции и словаря, что на большом объеме (а у меня есть номенклатура SKU (около 500 тыс строк), которая загоняется в словарь).
    Перепишу на коллекцию позже.

    Также в макросе есть модуль, где задействован Power Query (был задействован для другого проекта), закинул его в этот макрос. Так при режиме питания сбалансированный загрузка из PQ происходит ооочень долго в фоновом режиме(((
    Этот модуль тоже перепишу.

    Цитата
    написал:
    В коде есть профилирование времени, интересно, какие процессы тормозят больше всего.
    Результаты тестов (режим электропитания высокая производительность, приоритетность и задействованные ядра по умолчанию):

    Эксель в фокусе:



    Эксель в фоне
     
     
     
    Страницы: 1
    Читают тему
    Наверх