Что такое VBD_Kit_Interface_SDI?Это система управления отдельными процессами Excel, которая позволяет:
Запускать множество независимых Excel-процессов из одного макроса
Изолировать выполнение кода, чтобы сбои в одном процессе не влияли на другие
Реализовать параллельную обработку (псевдо-многопоточность в VBA)Контролировать жизненный цикл каждого процесса
Архитектура системы
[Главный Excel процесс (родительский)]
        ↓
    [COM-интерфейс]
        ↓
[Дочерний Excel процесс 1] ← независимый
[Дочерний Excel процесс 2] ← независимый
[Дочерний Excel процесс 3] ← независимый
Реализация VBD_Kit_Interface_SDI1. Основной класс CExcelSDIProcessvba
' clsExcelSDIProcess.cls
Option Explicit

Private Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessId As Long
    dwThreadId As Long
End Type

Private Type STARTUPINFO
    cb As Long
    lpReserved As String
    lpDesktop As String
    lpTitle As String
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCountChars As Long
    dwYCountChars As Long
    dwFillAttribute As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Long
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type

' API функции для управления процессами
#If VBA7 Then
    Private Declare PtrSafe Function CreateProcess Lib "kernel32" _
        Alias "CreateProcessA" ( _
        ByVal lpApplicationName As String, _
        ByVal lpCommandLine As String, _
        ByVal lpProcessAttributes As Long, _
        ByVal lpThreadAttributes As Long, _
        ByVal bInheritHandles As Long, _
        ByVal dwCreationFlags As Long, _
        ByVal lpEnvironment As Long, _
        ByVal lpCurrentDirectory As String, _
        lpStartupInfo As STARTUPINFO, _
        lpProcessInformation As PROCESS_INFORMATION) As Long
        
    Private Declare PtrSafe Function TerminateProcess Lib "kernel32" ( _
        ByVal hProcess As Long, _
        ByVal uExitCode As Long) As Long
        
    Private Declare PtrSafe Function CloseHandle Lib "kernel32" ( _
        ByVal hObject As LongPtr) As Long
        
    Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" ( _
        ByVal hHandle As LongPtr, _
        ByVal dwMilliseconds As Long) As Long
#Else
    ' аналогичные объявления для 32-bit
#End If

' COM объект Excel для дочернего процесса
Private m_excelApp As Object
Private m_workbook As Object
Private m_processInfo As PROCESS_INFORMATION
Private m_processId As Long
Private m_isRunning As Boolean

Public Property Get ProcessID() As Long
    ProcessID = m_processId
End Property

Public Property Get IsRunning() As Boolean
    IsRunning = m_isRunning
End Property

Public Property Get ExcelApp() As Object
    Set ExcelApp = m_excelApp
End Property

Public Property Get Workbook() As Object
    Set Workbook = m_workbook
End Property

' Запуск нового изолированного процесса Excel
Public Function CreateNewProcess(Optional ByVal excelPath As String = "") As Boolean
    On Error GoTo ErrorHandler
    
    Dim cmdLine As String
    Dim si As STARTUPINFO
    
    ' Если путь к Excel не указан, используем стандартный
    If excelPath = "" Then
        excelPath = Environ("ProgramFiles") & "\Microsoft Office\root\Office16\EXCEL.EXE"
        If Dir(excelPath) = "" Then
            excelPath = "EXCEL.EXE"  ' Из PATH
        End If
    End If
    
    ' Командная строка для запуска Excel в отдельном процессе
    cmdLine = """" & excelPath & """ /automation /e"
    
    ' Настройка структуры STARTUPINFO
    si.cb = Len(si)
    si.dwFlags = &H1  ' STARTF_USESHOWWINDOW
    si.wShowWindow = 0  ' SW_HIDE - скрытый режим
    
    ' Создаем процесс
    If CreateProcess(vbNullString, cmdLine, 0, 0, 0, _
                    &H10, 0, vbNullString, si, m_processInfo) = 0 Then
        Err.Raise 1001, , "Не удалось создать процесс Excel"
    End If
    
    m_processId = m_processInfo.dwProcessId
    m_isRunning = True
    
    ' Ждем запуска и подключаемся через COM
    Application.Wait Now + TimeValue("00:00:02")
    ConnectToExcelProcess
    
    CreateNewProcess = True
    Exit Function
    
ErrorHandler:
    m_isRunning = False
    CreateNewProcess = False
End Function

' Подключение к запущенному Excel через COM
Private Sub ConnectToExcelProcess()
    On Error Resume Next
    
    Dim obj As Object
    Dim attempts As Integer
    
    For attempts = 1 To 10
        ' Пытаемся найти запущенный Excel по ProcessID
        For Each obj In GetObject(, "Excel.Application")
            If obj.hWnd <> 0 Then  ' Приблизительная проверка
                Set m_excelApp = obj
                Exit For
            End If
        Next obj
        
        If Not m_excelApp Is Nothing Then
            Exit For
        End If
        
        Application.Wait Now + TimeValue("00:00:01")
    Next attempts
    
    If m_excelApp Is Nothing Then
        ' Создаем новый экземпляр, если не нашли
        Set m_excelApp = CreateObject("Excel.Application")
    End If
    
    ' Настройка Excel
    With m_excelApp
        .Visible = False
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
    End With
End Sub

' Загрузка книги в изолированный процесс
Public Function LoadWorkbook(ByVal filePath As String, _
                            Optional ByVal readOnly As Boolean = False) As Boolean
    On Error GoTo ErrorHandler
    
    If m_excelApp Is Nothing Then
        CreateNewProcess
    End If
    
    Set m_workbook = m_excelApp.Workbooks.Open(filePath, ReadOnly:=readOnly)
    LoadWorkbook = True
    Exit Function
    
ErrorHandler:
    LoadWorkbook = False
End Function

' Выполнение макроса в изолированном процессе
Public Function RunMacro(ByVal macroName As String, _
                        Optional ParamArray parameters() As Variant) As Variant
    On Error GoTo ErrorHandler
    
    If m_workbook Is Nothing Then
        Err.Raise 1002, , "Книга не загружена"
    End If
    
    Dim result As Variant
    
    Select Case UBound(parameters) - LBound(parameters) + 1
        Case 0
            result = m_excelApp.Run("'" & m_workbook.Name & "'!" & macroName)
        Case 1
            result = m_excelApp.Run("'" & m_workbook.Name & "'!" & macroName, _
                                   parameters(0))
        Case 2
            result = m_excelApp.Run("'" & m_workbook.Name & "'!" & macroName, _
                                   parameters(0), parameters(1))
        ' ... можно добавить больше параметров
        Case Else
            ' Для многих параметров используем CallByName
            Dim i As Long
            ReDim paramArrayCopy(0 To UBound(parameters)) As Variant
            For i = 0 To UBound(parameters)
                paramArrayCopy(i) = parameters(i)
            Next i
            
            result = CallByName(m_workbook, macroName, VbMethod, paramArrayCopy)
    End Select
    
    RunMacro = result
    Exit Function
    
ErrorHandler:
    RunMacro = CVErr(Err.Number)
End Function

' Асинхронное выполнение макроса
Public Sub RunMacroAsync(ByVal macroName As String, _
                        Optional ByVal callbackMacro As String = "")
    ' Реализация через Application.OnTime или таймер
    ' Это упрощенная версия
    On Error Resume Next
    
    If Not m_workbook Is Nothing Then
        m_excelApp.Run "'" & m_workbook.Name & "'!" & macroName
    End If
    
    ' Если указан callback, вызываем его в основном процессе
    If callbackMacro <> "" Then
        Application.OnTime Now, callbackMacro
    End If
End Sub

' Завершение процесса
Public Sub Terminate(Optional ByVal saveChanges As Boolean = False)
    On Error Resume Next
    
    If Not m_workbook Is Nothing Then
        m_workbook.Close saveChanges
        Set m_workbook = Nothing
    End If
    
    If Not m_excelApp Is Nothing Then
        m_excelApp.Quit
        Set m_excelApp = Nothing
    End If
    
    If m_processInfo.hProcess <> 0 Then
        TerminateProcess m_processInfo.hProcess, 0
        CloseHandle m_processInfo.hProcess
        CloseHandle m_processInfo.hThread
    End If
    
    m_isRunning = False
End Sub

Private Sub Class_Terminate()
    Terminate False
End Sub

2. Менеджер процессов CExcelSDIManager

' clsExcelSDIManager.cls
Option Explicit

Private m_processes As Collection
Private m_maxProcesses As Long
Private m_activeProcesses As Long

' Событийная модель
Public Event ProcessCreated(ByVal processId As Long, ByVal processIndex As Long)
Public Event ProcessTerminated(ByVal processId As Long, ByVal processIndex As Long)
Public Event ProcessError(ByVal processId As Long, ByVal errorMessage As String)
Public Event AllTasksCompleted()

Public Sub Initialize(Optional ByVal maxProcesses As Long = 4)
    Set m_processes = New Collection
    m_maxProcesses = maxProcesses
    m_activeProcesses = 0
End Sub

' Создание нового изолированного процесса
Public Function CreateProcess(Optional ByVal excelPath As String = "") As clsExcelSDIProcess
    If m_processes.Count >= m_maxProcesses Then
        Err.Raise 1003, , "Достигнуто максимальное количество процессов"
    End If
    
    Dim newProcess As clsExcelSDIProcess
    Set newProcess = New clsExcelSDIProcess
    
    If newProcess.CreateNewProcess(excelPath) Then
        m_processes.Add newProcess, CStr(newProcess.ProcessID)
        m_activeProcesses = m_activeProcesses + 1
        
        ' Генерируем событие
        RaiseEvent ProcessCreated(newProcess.ProcessID, m_processes.Count)
        
        Set CreateProcess = newProcess
    Else
        Set CreateProcess = Nothing
    End If
End Function

' Запуск задачи в свободном процессе
Public Function ExecuteTask(ByVal taskType As String, _
                           ByVal parameters As Variant, _
                           Optional ByVal timeoutSeconds As Long = 300) As Variant
    
    Dim freeProcess As clsExcelSDIProcess
    Set freeProcess = GetFreeProcess()
    
    If freeProcess Is Nothing Then
        ' Создаем новый процесс, если нет свободных
        Set freeProcess = CreateProcess()
    End If
    
    If Not freeProcess Is Nothing Then
        ' Загружаем книгу с задачей
        Dim workbookPath As String
        workbookPath = GetTaskWorkbook(taskType)
        
        If freeProcess.LoadWorkbook(workbookPath) Then
            ' Выполняем макрос
            Dim result As Variant
            result = freeProcess.RunMacro("ExecuteTask", parameters)
            
            ExecuteTask = result
        Else
            ExecuteTask = CVErr(1004)
        End If
    Else
        ExecuteTask = CVErr(1005)
    End If
End Function

' Параллельное выполнение массива задач
Public Sub ExecuteParallel(tasks() As Variant, _
                          Optional ByVal callback As String = "")
    
    Dim taskQueue As Collection
    Set taskQueue = New Collection
    
    ' Помещаем задачи в очередь
    Dim i As Long
    For i = LBound(tasks) To UBound(tasks)
        taskQueue.Add tasks(i)
    Next i
    
    ' Создаем процессы для параллельного выполнения
    Dim processes() As clsExcelSDIProcess
    ReDim processes(1 To m_maxProcesses)
    
    For i = 1 To m_maxProcesses
        If taskQueue.Count > 0 Then
            Set processes(i) = CreateProcess()
            
            If Not processes(i) Is Nothing Then
                ' Запускаем задачу в процессе
                StartTaskInProcess processes(i), taskQueue(1)
                taskQueue.Remove 1
            End If
        End If
    Next i
    
    ' Мониторинг выполнения
    MonitorCompletion processes, taskQueue, callback
End Sub

Private Function GetFreeProcess() As clsExcelSDIProcess
    Dim proc As clsExcelSDIProcess
    Dim i As Long
    
    For i = 1 To m_processes.Count
        Set proc = m_processes(i)
        If proc.IsRunning Then
            ' Проверяем, свободен ли процесс (нет активной задачи)
            ' Здесь можно добавить более сложную логику отслеживания состояния
            Set GetFreeProcess = proc
            Exit Function
        End If
    Next i
    
    Set GetFreeProcess = Nothing
End Function

Private Function GetTaskWorkbook(ByVal taskType As String) As String
    ' Определяем путь к книге в зависимости от типа задачи
    Select Case taskType
        Case "DataProcessing"
            GetTaskWorkbook = ThisWorkbook.Path & "\Tasks\DataProcessor.xlsm"
        Case "ReportGeneration"
            GetTaskWorkbook = ThisWorkbook.Path & "\Tasks\ReportGenerator.xlsm"
        Case "WebScraping"
            GetTaskWorkbook = ThisWorkbook.Path & "\Tasks\WebScraper.xlsm"
        Case Else
            GetTaskWorkbook = ThisWorkbook.Path & "\Tasks\GenericTask.xlsm"
    End Select
End Function

Private Sub StartTaskInProcess(proc As clsExcelSDIProcess, task As Variant)
    ' Запуск задачи в отдельном процессе
    On Error Resume Next
    
    ' Здесь можно реализовать более сложную логику запуска
    proc.RunMacroAsync "ProcessTask", "TaskCompletedCallback"
End Sub

Private Sub MonitorCompletion(processes() As clsExcelSDIProcess, _
                             taskQueue As Collection, _
                             callback As String)
    ' Мониторинг завершения задач
    Dim completed As Boolean
    Dim i As Long
    
    Do While True
        completed = True
        
        For i = 1 To UBound(processes)
            If Not processes(i) Is Nothing Then
                If processes(i).IsRunning Then
                    completed = False
                Else
                    ' Освобождаем процесс для новой задачи
                    If taskQueue.Count > 0 Then
                        StartTaskInProcess processes(i), taskQueue(1)
                        taskQueue.Remove 1
                        completed = False
                    End If
                End If
            End If
        Next i
        
        If completed And taskQueue.Count = 0 Then
            Exit Do
        End If
        
        DoEvents
        Application.Wait Now + TimeValue("00:00:01")
    Loop
    
    ' Вызываем callback, если указан
    If callback <> "" Then
        Application.OnTime Now, callback
    End If
    
    ' Генерируем событие
    RaiseEvent AllTasksCompleted
End Sub

' Остановка всех процессов
Public Sub TerminateAll(Optional ByVal saveChanges As Boolean = False)
    Dim proc As clsExcelSDIProcess
    Dim i As Long
    
    For i = m_processes.Count To 1 Step -1
        Set proc = m_processes(i)
        proc.Terminate saveChanges
        m_processes.Remove i
        
        RaiseEvent ProcessTerminated(proc.ProcessID, i)
    Next i
    
    m_activeProcesses = 0
End Sub

Public Property Get ProcessCount() As Long
    ProcessCount = m_processes.Count
End Property

Public Property Get ActiveProcesses() As Long
    ActiveProcesses = m_activeProcesses
End Property

Private Sub Class_Terminate()
    TerminateAll False
End Sub

3. Интерфейс для взаимодействия IExcelSDIInterface

' clsSDIInterface.cls - Основной интерфейс
Option Explicit

Implements ISDIInterface

Private m_manager As clsExcelSDIManager
Private m_settings As clsSDISettings

Private Sub Class_Initialize()
    Set m_manager = New clsExcelSDIManager
    Set m_settings = New clsSDISettings
    
    ' Загружаем настройки
    m_settings.LoadSettings
    m_manager.Initialize m_settings.MaxProcesses
End Sub

' ISDIInterface implementation
Private Sub ISDIInterface_CreateSDIProcess(Optional ByVal config As Variant)
    Dim newProcess As clsExcelSDIProcess
    Set newProcess = m_manager.CreateProcess(m_settings.ExcelPath)
    
    If Not newProcess Is Nothing Then
        ' Конфигурируем процесс
        ConfigureProcess newProcess, config
    End If
End Sub

Private Function ISDIInterface_ExecuteInSDI(ByVal taskType As String, _
                                           ByVal parameters As Variant) As Variant
    
    Dim result As Variant
    result = m_manager.ExecuteTask(taskType, parameters)
    
    ISDIInterface_ExecuteInSDI = result
End Function

Private Sub ISDIInterface_ExecuteParallel(tasks() As Variant, _
                                         Optional ByVal callback As String)
    
    m_manager.ExecuteParallel tasks, callback
End Sub

Private Property Get ISDIInterface_ProcessCount() As Long
    ISDIInterface_ProcessCount = m_manager.ProcessCount
End Property

Private Sub ISDIInterface_TerminateAll()
    m_manager.TerminateAll m_settings.SaveOnExit
End Sub

Private Sub ConfigureProcess(proc As clsExcelSDIProcess, config As Variant)
    ' Настройка параметров процесса
    With proc.ExcelApp
        .Visible = m_settings.ShowExcelWindows
        .DisplayAlerts = m_settings.ShowAlerts
        .ScreenUpdating = m_settings.ScreenUpdating
        .Calculation = m_settings.CalculationMode
    End With
    
    ' Дополнительные настройки из конфига
    If IsArray(config) Then
        ' Обработка конфигурации
    End If
End Sub

' Публичные методы для удобства
Public Function CreateProcessWrapper(Optional ByVal excelPath As String = "") _
                                    As clsExcelSDIProcess
    
    Set CreateProcessWrapper = m_manager.CreateProcess(excelPath)
End Function

Public Sub RunIsolatedMacro(ByVal workbookPath As String, _
                           ByVal macroName As String, _
                           Optional ParamArray params() As Variant)
    
    Dim proc As clsExcelSDIProcess
    Set proc = CreateProcessWrapper
    
    If Not proc Is Nothing Then
        If proc.LoadWorkbook(workbookPath) Then
            Dim result As Variant
            result = proc.RunMacro(macroName, params)
            
            ' Обработка результата
            ProcessResult result
        End If
        
        ' Автоматическое завершение
        proc.Terminate True
    End If
End Sub

Private Sub ProcessResult(result As Variant)
    ' Обработка результатов выполнения
    If Not IsError(result) Then
        ' Логирование или передача результатов
        Debug.Print "Результат выполнения: " & CStr(result)
    End If
End Sub

4. Класс настроек clsSDISettings

' clsSDISettings.cls
Option Explicit

Private Type TSettings
    MaxProcesses As Long
    ExcelPath As String
    ShowExcelWindows As Boolean
    ShowAlerts As Boolean
    ScreenUpdating As Boolean
    CalculationMode As Long
    SaveOnExit As Boolean
    TimeoutSeconds As Long
End Type

Private this As TSettings

Public Property Get MaxProcesses() As Long
    MaxProcesses = this.MaxProcesses
End Property

Public Property Let MaxProcesses(ByVal value As Long)
    this.MaxProcesses = Application.WorksheetFunction.Min(value, 8) ' Максимум 8 процессов
End Property

Public Property Get ExcelPath() As String
    ExcelPath = this.ExcelPath
End Property

Public Property Get ShowExcelWindows() As Boolean
    ShowExcelWindows = this.ShowExcelWindows
End Property

Public Property Get ShowAlerts() As Boolean
    ShowAlerts = this.ShowAlerts
End Property

Public Property Get ScreenUpdating() As Boolean
    ScreenUpdating = this.ScreenUpdating
End Property

Public Property Get CalculationMode() As Long
    CalculationMode = this.CalculationMode
End Property

Public Property Get SaveOnExit() As Boolean
    SaveOnExit = this.SaveOnExit
End Property

Public Property Get TimeoutSeconds() As Long
    TimeoutSeconds = this.TimeoutSeconds
End Property

Public Sub LoadSettings()
    ' Загрузка настроек из файла или реестра
    On Error Resume Next
    
    ' Значения по умолчанию
    this.MaxProcesses = 4
    this.ExcelPath = ""
    this.ShowExcelWindows = False
    this.ShowAlerts = False
    this.ScreenUpdating = False
    this.CalculationMode = -4105 ' xlCalculationManual
    this.SaveOnExit = False
    this.TimeoutSeconds = 300
    
    ' Можно загружать из XML/JSON файла
    ' Или из раздела реестра HKCU\Software\VBD_Kit
End Sub

Public Sub SaveSettings()
    ' Сохранение настроек
    ' Реализация по необходимости
End Sub

5. Пример использования

' Module: modSDIExample
Option Explicit

Private sdiManager As clsSDIInterface

' Инициализация системы
Public Sub InitializeSDISystem()
    Set sdiManager = New clsSDIInterface
    
    ' Создаем несколько изолированных процессов
    Dim i As Long
    For i = 1 To 3
        sdiManager.CreateProcessWrapper
    Next i
    
    Debug.Print "Система SDI инициализирована. Процессов: " & _
                sdiManager.ProcessCount
End Sub

' Пример параллельной обработки данных
Public Sub ProcessDataInParallel()
    Dim tasks(1 To 10) As Variant
    Dim i As Long
    
    ' Создаем задачи для параллельного выполнения
    For i = 1 To 10
        tasks(i) = Array("DataProcessing", "Task_" & i, Now)
    Next i
    
    ' Запускаем параллельно
    sdiManager.ExecuteParallel tasks, "OnTasksCompleted"
    
    MsgBox "Задачи запущены в параллельных процессах", vbInformation
End Sub

' Callback при завершении всех задач
Private Sub OnTasksCompleted()
    MsgBox "Все задачи завершены!", vbInformation
    
    ' Можно получить результаты
    CollectResults
End Sub

' Запуск изолированного макроса
Public Sub RunIsolatedTask()
    Dim result As Variant
    
    result = sdiManager.ExecuteInSDI("ReportGeneration", _
                                    Array("MonthlyReport", Date))
    
    If Not IsError(result) Then
        MsgBox "Отчет сгенерирован: " & result, vbInformation
    End If
End Sub

' Пример мониторинга процессов
Public Sub MonitorProcesses()
    Dim i As Long
    For i = 1 To sdiManager.ProcessCount
        Debug.Print "Процесс " & i & ": " & _
                    IIf(sdiManager.IsProcessRunning(i), "Активен", "Неактивен")
    Next i
End Sub

' Очистка системы
Public Sub CleanupSDISystem()
    sdiManager.TerminateAll
    Set sdiManager = Nothing
    
    Debug.Print "Система SDI очищена"
End Sub

Ключевые преимущества VBD_Kit_Interface_SDI1. 
Изоляция процессов
Краш одного Excel не уронит всю систему
Индивидуальные настройки для каждого процесса
Разделение памяти - каждый процесс в своем адресном пространстве

2. Параллельная обработка

' Можно одновременно:
' - Обрабатывать большие данные
' - Генерировать отчеты
' - Скачивать информацию из интернета
' - Выполнять сложные расчеты

3. Контроль жизненного цикла
Автоматическое создание/уничтожение процессов
Мониторинг состояния (жив/умер)Обработка ошибок на уровне процесса

4. Гибкость. Можно запускать разные версии Excel (2010, 2013, 2016, 365)
Разные конфигурации для разных задач
Динамическое масштабирование (добавление/удаление процессов)Типичные сценарии использования
Сценарий 1: Пакетная обработка файлов

Public Sub ProcessMultipleFiles()
    Dim files As Collection
    Set files = GetFilesToProcess("C:\Data\*.xlsx")
    
    Dim file As Variant
    For Each file In files
        ' Каждый файл в отдельном процессе
        sdiManager.RunIsolatedMacro file, "ProcessFile"
    Next file
End Sub

Сценарий 2: Параллельные расчеты

Public Sub ParallelCalculations()
    Dim tasks(1 To 100) As Variant
    
    ' Создаем 100 независимых задач
    Dim i As Long
    For i = 1 To 100
        tasks(i) = Array("Calculate", i, Rnd())
    Next i
    
    ' Запускаем параллельно в 4 процессах
    sdiManager.ExecuteParallel tasks, "CalculationsComplete"
End Sub

Сценарий 3: Веб-скрапинг с изоляцией

Public Sub ParallelWebScraping()
    Dim urls() As String
    urls = GetURLsToScrape()
    
    Dim tasks() As Variant
    ReDim tasks(LBound(urls) To UBound(urls))
    
    Dim i As Long
    For i = LBound(urls) To UBound(urls)
        tasks(i) = Array("ScrapeURL", urls(i))
    Next i
    
    ' Если один сайт упадет - остальные продолжат работу
    sdiManager.ExecuteParallel tasks
End Sub
Ограничения и решения
Ограничение: Обмен данными между процессами
Решение:

' Использовать промежуточные файлы
Public Sub ShareDataViaFiles(proc As clsExcelSDIProcess, data As Variant)
    ' Сохраняем данные во временный файл
    SaveToTempFile data, "temp_data.dat"
    
    ' Передаем путь к файлу
    proc.RunMacro "LoadDataFromFile", "C:\Temp\temp_data.dat"
End Sub

Ограничение: Производительность при создании процессов
Решение:

' Использовать пул процессов
Public Sub InitializeProcessPool(count As Long)
    Dim i As Long
    For i = 1 To count
        Dim proc As clsExcelSDIProcess
        Set proc = New clsExcelSDIProcess
        
        ' Создаем, но не загружаем книги
        proc.CreateNewProcess
        
        ' Добавляем в пул ожидания
        AddToProcessPool proc
    Next i
End Sub

Оптимизации для производительности
1. Reuse процессов

Private m_processPool As Collection

Public Function GetProcessFromPool() As clsExcelSDIProcess
    If m_processPool.Count > 0 Then
        Set GetProcessFromPool = m_processPool(1)
        m_processPool.Remove 1
    Else
        Set GetProcessFromPool = CreateProcessWrapper
    End If
End Function

Public Sub ReturnProcessToPool(proc As clsExcelSDIProcess)
    ' Сбрасываем состояние
    proc.ExcelApp.Workbooks.Close
    
    ' Возвращаем в пул
    m_processPool.Add proc
End Sub

2. Ленивая инициализацияvba

Public Function GetOrCreateProcess() As clsExcelSDIProcess
    Static processes As Collection
    
    If processes Is Nothing Then
        Set processes = New Collection
    End If
    
    If processes.Count < m_maxProcesses Then
        Dim proc As clsExcelSDIProcess
        Set proc = CreateProcessWrapper
        processes.Add proc
        
        Set GetOrCreateProcess = proc
    Else
        ' Используем наименее загруженный процесс
        Set GetOrCreateProcess = GetLeastBusyProcess(processes)
    End If
End Function

ЗаключениеVBD_Kit_Interface_SDI предоставляет мощный механизм для:
Создания устойчивых Excel-приложений
Параллельной обработки данных
Изоляции критических операций
Масштабирования вычислительных задач
Это решение особенно полезно для:
Финансовых расчетов, где нужна стабильность
Обработки больших данных
Автоматизации отчетности с множеством источников
Систем, где критична отказоустойчивость
Хотите, чтобы я подробнее разобрал какой-то конкретный аспект или добавил дополнительные функции?

Вот полное решение для **параметрического тригонометрического ряда Фурье** без дифференцирования, с минимальным кодом:

## **Простейшая реализация параметрического ряда Фурье на VBA**

### **1. Основной модуль для вычисления коэффициентов Фурье**

```vba
' Module: modFourierSeries
Option Explicit

' Структура для хранения коэффициентов Фурье
Type FourierCoefficients
    a0 As Double
    a() As Double  ' Коэффициенты при cos
    b() As Double  ' Коэффициенты при sin
End Type

' Вычисление коэффициентов Фурье для параметрической функции
' x(t), y(t) - массивы значений (t от 0 до 2π)
' n - количество гармоник
Public Sub ComputeFourierCoefficients(x() As Double, y() As Double, _
                                     ByVal n As Long, _
                                     ByRef coeffX As FourierCoefficients, _
                                     ByRef coeffY As FourierCoefficients)
    
    Dim Npoints As Long
    Npoints = UBound(x)
    
    ' Инициализация коэффициентов
    coeffX.a0 = 0
    coeffY.a0 = 0
    ReDim coeffX.a(1 To n)
    ReDim coeffX.b(1 To n)
    ReDim coeffY.a(1 To n)
    ReDim coeffY.b(1 To n)
    
    ' Вычисление a0
    Dim i As Long, k As Long
    For i = 1 To Npoints
        coeffX.a0 = coeffX.a0 + x(i)
        coeffY.a0 = coeffY.a0 + y(i)
    Next i
    coeffX.a0 = coeffX.a0 / Npoints
    coeffY.a0 = coeffY.a0 / Npoints
    
    ' Вычисление коэффициентов an, bn
    Dim t As Double, cos_nt As Double, sin_nt As Double
    
    For k = 1 To n
        coeffX.a(k) = 0
        coeffX.b(k) = 0
        coeffY.a(k) = 0
        coeffY.b(k) = 0
        
        For i = 1 To Npoints
            t = 2 * Application.WorksheetFunction.Pi() * (i - 1) / Npoints
            cos_nt = Cos(k * t)
            sin_nt = Sin(k * t)
            
            coeffX.a(k) = coeffX.a(k) + x(i) * cos_nt
            coeffX.b(k) = coeffX.b(k) + x(i) * sin_nt
            coeffY.a(k) = coeffY.a(k) + y(i) * cos_nt
            coeffY.b(k) = coeffY.b(k) + y(i) * sin_nt
        Next i
        
        coeffX.a(k) = 2 * coeffX.a(k) / Npoints
        coeffX.b(k) = 2 * coeffX.b(k) / Npoints
        coeffY.a(k) = 2 * coeffY.a(k) / Npoints
        coeffY.b(k) = 2 * coeffY.b(k) / Npoints
    Next k
End Sub

' Восстановление функции по коэффициентам Фурье
Public Function EvaluateFourierSeries(ByVal t As Double, _
                                     coeff As FourierCoefficients, _
                                     ByVal n As Long) As Double
    
    Dim result As Double
    result = coeff.a0 / 2
    
    Dim k As Long
    For k = 1 To n
        result = result + coeff.a(k) * Cos(k * t) + coeff.b(k) * Sin(k * t)
    Next k
    
    EvaluateFourierSeries = result
End Function

' Параметрическое восстановление кривой
Public Sub EvaluateParametricFourier(ByVal t As Double, _
                                     coeffX As FourierCoefficients, _
                                     coeffY As FourierCoefficients, _
                                     ByVal n As Long, _
                                     ByRef x_out As Double, _
                                     ByRef y_out As Double)
    
    x_out = EvaluateFourierSeries(t, coeffX, n)
    y_out = EvaluateFourierSeries(t, coeffY, n)
End Sub
```

### **2. Минимальная реализация с замыканием на Excel**

```vba
' Module: modFourierSimple
Option Explicit

' Простейшая функция: принимает два диапазона (x и y) и возвращает аппроксимацию
Public Function FourierApproximation(rngX As Range, rngY As Range, _
                                    Optional harmonics As Long = 10, _
                                    Optional t As Double = 0) As Variant
    
    Dim xData() As Variant, yData() As Variant
    Dim coeffX As FourierCoefficients, coeffY As FourierCoefficients
    Dim x_out As Double, y_out As Double
    
    ' Загружаем данные из диапазонов
    xData = rngX.Value
    yData = rngY.Value
    
    ' Проверяем размерность
    If UBound(xData, 1) <> UBound(yData, 1) Then
        FourierApproximation = CVErr(xlErrValue)
        Exit Function
    End If
    
    ' Вычисляем коэффициенты
    ComputeFourierCoefficientsSimple xData, yData, harmonics, coeffX, coeffY
    
    ' Вычисляем значение в точке t
    EvaluateParametricFourier t, coeffX, coeffY, harmonics, x_out, y_out
    
    ' Возвращаем массив из двух значений
    FourierApproximation = Array(x_out, y_out)
End Function

' Упрощенная версия вычисления коэффициентов
Private Sub ComputeFourierCoefficientsSimple(xData As Variant, yData As Variant, _
                                            ByVal n As Long, _
                                            ByRef coeffX As FourierCoefficients, _
                                            ByRef coeffY As FourierCoefficients)
    
    Dim Npoints As Long
    Npoints = UBound(xData, 1)
    
    ' Инициализация
    coeffX.a0 = 0
    coeffY.a0 = 0
    ReDim coeffX.a(1 To n)
    ReDim coeffX.b(1 To n)
    ReDim coeffY.a(1 To n)
    ReDim coeffY.b(1 To n)
    
    Dim i As Long, k As Long
    Dim t As Double, cos_kt As Double, sin_kt As Double
    
    ' a0
    For i = 1 To Npoints
        coeffX.a0 = coeffX.a0 + xData(i, 1)
        coeffY.a0 = coeffY.a0 + yData(i, 1)
    Next i
    coeffX.a0 = coeffX.a0 / Npoints
    coeffY.a0 = coeffY.a0 / Npoints
    
    ' an, bn
    For k = 1 To n
        For i = 1 To Npoints
            t = 2 * Application.WorksheetFunction.Pi() * (i - 1) / Npoints
            cos_kt = Cos(k * t)
            sin_kt = Sin(k * t)
            
            coeffX.a(k) = coeffX.a(k) + xData(i, 1) * cos_kt
            coeffX.b(k) = coeffX.b(k) + xData(i, 1) * sin_kt
            coeffY.a(k) = coeffY.a(k) + yData(i, 1) * cos_kt
            coeffY.b(k) = coeffY.b(k) + yData(i, 1) * sin_kt
        Next i
        
        coeffX.a(k) = 2 * coeffX.a(k) / Npoints
        coeffX.b(k) = 2 * coeffX.b(k) / Npoints
        coeffY.a(k) = 2 * coeffY.a(k) / Npoints
        coeffY.b(k) = 2 * coeffY.b(b) / Npoints
    Next k
End Sub
```

### **3. Готовый рабочий пример для Excel**

```vba
' Module: modFourierExample
Option Explicit

' Пример использования: аппроксимация окружности
Public Sub TestFourierCircle()
    Dim i As Long, N As Long
    N = 100
    
    ' Создаем данные для окружности
    Dim x() As Double, y() As Double
    ReDim x(1 To N)
    ReDim y(1 To N)
    
    Dim t As Double
    For i = 1 To N
        t = 2 * Application.WorksheetFunction.Pi() * (i - 1) / N
        x(i) = Cos(t)
        y(i) = Sin(t)
    Next i
    
    ' Вычисляем коэффициенты Фурье
    Dim coeffX As FourierCoefficients, coeffY As FourierCoefficients
    Dim harmonics As Long: harmonics = 5
    
    ComputeFourierCoefficients x, y, harmonics, coeffX, coeffY
    
    ' Восстанавливаем кривую
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets.Add
    
    ws.Range("A1").Value = "t"
    ws.Range("B1").Value = "Исходный X"
    ws.Range("C1").Value = "Исходный Y"
    ws.Range("D1").Value = "Фурье X"
    ws.Range("E1").Value = "Фурье Y"
    
    Dim t_val As Double, x_fourier As Double, y_fourier As Double
    For i = 1 To 360
        t_val = 2 * Application.WorksheetFunction.Pi() * (i - 1) / 360
        
        ' Оригинальная функция (окружность)
        Dim x_orig As Double, y_orig As Double
        x_orig = Cos(t_val)
        y_orig = Sin(t_val)
        
        ' Аппроксимация Фурье
        EvaluateParametricFourier t_val, coeffX, coeffY, harmonics, x_fourier, y_fourier
        
        ws.Cells(i + 1, 1).Value = t_val
        ws.Cells(i + 1, 2).Value = x_orig
        ws.Cells(i + 1, 3).Value = y_orig
        ws.Cells(i + 1, 4).Value = x_fourier
        ws.Cells(i + 1, 5).Value = y_fourier
    Next i
    
    ' Строим график
    Dim ch As Chart
    Set ch = ws.Shapes.AddChart2(240, xlXYScatterLinesNoMarkers).Chart
    
    With ch
        .SetSourceData Source:=ws.Range("B2:C361")
        .SeriesCollection.NewSeries
        .SeriesCollection(2).Values = ws.Range("D2:D361")
        .SeriesCollection(2).XValues = ws.Range("E2:E361")
        .SeriesCollection(1).Name = "Исходная окружность"
        .SeriesCollection(2).Name = "Аппроксимация Фурье"
    End With
    
    MsgBox "Аппроксимация завершена!", vbInformation
End Sub

' Быстрая функция для использования в ячейках Excel
Public Function FOURIER_X(rngX As Range, rngY As Range, _
                         t As Double, Optional n As Long = 10) As Double
    
    Dim result As Variant
    result = FourierApproximation(rngX, rngY, n, t)
    
    If IsArray(result) Then
        FOURIER_X = result(0)
    Else
        FOURIER_X = CVErr(xlErrValue)
    End If
End Function

Public Function FOURIER_Y(rngX As Range, rngY As Range, _
                         t As Double, Optional n As Long = 10) As Double
    
    Dim result As Variant
    result = FourierApproximation(rngX, rngY, n, t)
    
    If IsArray(result) Then
        FOURIER_Y = result(1)
    Else
        FOURIER_Y = CVErr(xlErrValue)
    End If
End Function
```

### **4. Ультра-простая версия "без лишней фигни"**

```vba
' Module: modFourierMinimal
Option Explicit

' Минимальный ряд Фурье - только самое необходимое
Public Sub SimpleFourierFit(inputX As Range, inputY As Range, _
                           outputX As Range, outputY As Range, _
                           Optional harmonics As Long = 20)
    
    Dim xData As Variant, yData As Variant
    xData = inputX.Value
    yData = inputY.Value
    
    Dim N As Long, M As Long
    N = UBound(xData, 1)
    M = harmonics
    
    ' Вычисляем коэффициенты напрямую
    Dim a0_x As Double, a0_y As Double
    Dim a_x() As Double, b_x() As Double
    Dim a_y() As Double, b_y() As Double
    
    ReDim a_x(1 To M)
    ReDim b_x(1 To M)
    ReDim a_y(1 To M)
    ReDim b_y(1 To M)
    
    ' a0
    Dim i As Long, k As Long
    For i = 1 To N
        a0_x = a0_x + xData(i, 1)
        a0_y = a0_y + yData(i, 1)
    Next i
    a0_x = a0_x / N
    a0_y = a0_y / N
    
    ' an, bn
    Dim t As Double, cosVal As Double, sinVal As Double
    
    For k = 1 To M
        For i = 1 To N
            t = 6.28318530717959 * (i - 1) / N  ' 2π
            cosVal = Cos(k * t)
            sinVal = Sin(k * t)
            
            a_x(k) = a_x(k) + xData(i, 1) * cosVal
            b_x(k) = b_x(k) + xData(i, 1) * sinVal
            a_y(k) = a_y(k) + yData(i, 1) * cosVal
            b_y(k) = b_y(k) + yData(i, 1) * sinVal
        Next i
        
        a_x(k) = 2 * a_x(k) / N
        b_x(k) = 2 * b_x(k) / N
        a_y(k) = 2 * a_y(k) / N
        b_y(k) = 2 * b_y(k) / N
    Next k
    
    ' Восстанавливаем кривую
    Dim outRows As Long
    outRows = outputX.Rows.Count
    
    Dim x_out As Double, y_out As Double
    Dim j As Long
    
    For j = 1 To outRows
        t = 6.28318530717959 * (j - 1) / outRows
        
        x_out = a0_x / 2
        y_out = a0_y / 2
        
        For k = 1 To M
            x_out = x_out + a_x(k) * Cos(k * t) + b_x(k) * Sin(k * t)
            y_out = y_out + a_y(k) * Cos(k * t) + b_y(k) * Sin(k * t)
        Next k
        
        outputX.Cells(j, 1).Value = x_out
        outputY.Cells(j, 1).Value = y_out
    Next j
End Sub
```

### **5. Готовые формулы для использования в Excel**

Вставьте эти UDF (User Defined Functions) для использования напрямую в ячейках:

```vba
' UDF функции для Excel
Public Function FOUPARAM_X(x_range As Range, y_range As Range, _
                          t As Double, Optional n_harmonics As Long = 15) As Double
    
    Dim x_data As Variant, y_data As Variant
    x_data = x_range.Value
    y_data = y_range.Value
    
    Dim N As Long
    N = UBound(x_data, 1)
    
    ' Вычисляем a0_x
    Dim a0_x As Double
    Dim i As Long
    For i = 1 To N
        a0_x = a0_x + x_data(i, 1)
    Next i
    a0_x = a0_x / N
    
    ' Вычисляем an_x, bn_x
    Dim result As Double
    result = a0_x / 2
    
    Dim k As Long
    Dim t_param As Double, cos_kt As Double, sin_kt As Double
    
    For k = 1 To n_harmonics
        Dim an_x As Double, bn_x As Double
        an_x = 0
        bn_x = 0
        
        For i = 1 To N
            t_param = 2 * Application.WorksheetFunction.Pi() * (i - 1) / N
            cos_kt = Cos(k * t_param)
            sin_kt = Sin(k * t_param)
            
            an_x = an_x + x_data(i, 1) * cos_kt
            bn_x = bn_x + x_data(i, 1) * sin_kt
        Next i
        
        an_x = 2 * an_x / N
        bn_x = 2 * bn_x / N
        
        result = result + an_x * Cos(k * t) + bn_x * Sin(k * t)
    Next k
    
    FOUPARAM_X = result
End Function

Public Function FOUPARAM_Y(x_range As Range, y_range As Range, _
                          t As Double, Optional n_harmonics As Long = 15) As Double
    
    Dim x_data As Variant, y_data As Variant
    x_data = x_range.Value
    y_data = y_range.Value
    
    Dim N As Long
    N = UBound(y_data, 1)
    
    ' Вычисляем a0_y
    Dim a0_y As Double
    Dim i As Long
    For i = 1 To N
        a0_y = a0_y + y_data(i, 1)
    Next i
    a0_y = a0_y / N
    
    ' Вычисляем an_y, bn_y
    Dim result As Double
    result = a0_y / 2
    
    Dim k As Long
    Dim t_param As Double, cos_kt As Double, sin_kt As Double
    
    For k = 1 To n_harmonics
        Dim an_y As Double, bn_y As Double
        an_y = 0
        bn_y = 0
        
        For i = 1 To N
            t_param = 2 * Application.WorksheetFunction.Pi() * (i - 1) / N
            cos_kt = Cos(k * t_param)
            sin_kt = Sin(k * t_param)
            
            an_y = an_y + y_data(i, 1) * cos_kt
            bn_y = bn_y + y_data(i, 1) * sin_kt
        Next i
        
        an_y = 2 * an_y / N
        bn_y = 2 * bn_y / N
        
        result = result + an_y * Cos(k * t) + bn_y * Sin(k * t)
    Next k
    
    FOUPARAM_Y = result
End Function
```

### **6. Как использовать в Excel:**

1. **В ячейках Excel:**
```
=X: =FOUPARAM_X($A$2:$A$100, $B$2:$B$100, C2, 20)
=Y: =FOUPARAM_Y($A$2:$A$100, $B$2:$B$100, C2, 20)
```
Где:
- `$A$2:$A$100` - исходные X координаты
- `$B$2:$B$100` - исходные Y координаты  
- `C2` - значение параметра t (от 0 до 2π)
- `20` - количество гармоник (опционально)

2. **Из VBA:**
```vba
' Просто вызовите
Call SimpleFourierFit(Range("A2:A100"), Range("B2:B100"), _
                     Range("D2:D361"), Range("E2:E361"), 25)
```

### **Ключевые особенности этого решения:**

1. **Без дифференцирования** - используем только суммы и тригонометрические функции
2. **Без лишней фигни** - минимальный код, только суть
3. **Параметрический вид** - отдельные ряды для x(t) и y(t)
4. **Работает напрямую с данными Excel**
5. **Не требует дополнительных библиотек**

### **Что делает этот код:**

1. **Берет ваши исходные точки (x, y)**
2. **Вычисляет коэффициенты Фурье** для x и y отдельно
3. **Восстанавливает кривую** по формуле:
   ```
   x(t) = a0_x/2 + Σ[an_x·cos(nt) + bn_x·sin(nt)]
   y(t) = a0_y/2 + Σ[an_y·cos(nt) + bn_y·sin(nt)]
   ```
4. **t ∈ [0, 2π]** - параметр, пробегающий полный период

Это **классический тригонометрический ряд Фурье в параметрической форме**, без производных, интегралов (используем дискретные суммы) и сложных математических конструкций.

Ключевые оптимизации:
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

Мы имеем дело с большим макросом, который обрабатывает несколько файлов данных (продажи, прайс, структура, штрихкод, остатки) и заполняет шаблон.
Проблема в том, что на ноутбуке макрос работает медленнее, особенно когда 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После этих изменений разница между активным и фоновым режимом должна уменьшиться.Хотите, чтобы я подробнее разобрал конкретный модуль или помог реализовать какую-то из оптимизаций?

Отличная задача! Нужно создать Excel-файл, который при открытии показывает только пользовательскую форму, а сама книга остается скрытой. 
Вот комплексное решение:
Полный код для реализации

1. Модуль ThisWorkbook

Option Explicit
' Флаг для отслеживания состояния формы
Private m_UserFormOpen As Boolean
Private Sub Workbook_Open()
    On Error Resume Next
        ' Скрываем всё приложение Excel (временно)
    Application.Visible = False
        ' Ждем, чтобы избежать мерцания
    Application.Wait Now + TimeValue("00:00:01")
        ' Скрываем все окна текущей книги
    Dim win As Window
    For Each win In Me.Windows
        win.Visible = False
    Next win
        ' Показываем приложение
    Application.Visible = True
        ' Скрываем текущую книгу
    Me.Windows(1).Visible = False
        ' Показываем форму
    m_UserFormOpen = True
    UserForm1.Show vbModeless
        ' Устанавливаем обработчики событий
    SetApplicationEvents
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    ' Закрываем форму перед закрытием книги
    If m_UserFormOpen Then
        Unload UserForm1
    End If
End Sub
Private Sub SetApplicationEvents()
    ' Устанавливаем обработчик события смены окна
    Application.OnWindow = "OnWindowChange"
End Sub

2. Модуль UserForm1

Option Explicit
Private Sub UserForm_Initialize()
    ' Настройки формы при инициализации
    Me.Caption = "Моя форма управления"
    Me.StartUpPosition = 0  ' Ручная позиция
    Me.Left = Application.Left + 100
    Me.Top = Application.Top + 100
End Sub
Private Sub UserForm_Activate()
    ' При активации формы убеждаемся, что книга скрыта
    ThisWorkbook.Windows(1).Visible = False
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    ' При закрытии формы закрываем книгу
    ThisWorkbook.Saved = True  ' Помечаем как сохраненную
    ThisWorkbook.Close SaveChanges:=False
End Sub
' Пример кнопки закрытия на форме
Private Sub CommandButtonClose_Click()
    Unload Me
End Sub

3. Стандартный модуль Module1

Option Explicit
' API-функции для скрытия окна Excel
#If VBA7 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
        ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function ShowWindow Lib "user32" ( _
        ByVal hWnd As LongPtr, ByVal nCmdShow As Long) As Long
#Else
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
        ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function ShowWindow Lib "user32" ( _
        ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
#End If
Private Const SW_HIDE As Long = 0
Private Const SW_SHOW As Long = 5
' Глобальная переменная для отслеживания
Public g_FormIsOpen As Boolean
Public Sub OnWindowChange(ByVal Book As Workbook, ByVal Wn As Window)
    ' Этот макрос вызывается при изменении активного окна
    If g_FormIsOpen And Book.Name = ThisWorkbook.Name Then
        ' Если пытаются активировать нашу книгу - скрываем ее
        ThisWorkbook.Windows(1).Visible = False
        UserForm1.SetFocus
    End If
End Sub
Public Sub HideExcelWindow()
    ' Скрывает главное окно Excel
    Dim hWnd As LongPtr
    Dim windowName As String
        ' Получаем заголовок окна Excel
    windowName = Application.Caption
    If Len(windowName) = 0 Then windowName = "Microsoft Excel"
        ' Находим и скрываем окно
    hWnd = FindWindow("XLMAIN", windowName)
    If hWnd <> 0 Then
        ShowWindow hWnd, SW_HIDE
    End If
End Sub
Public Sub ShowExcelWindow()
    ' Показывает главное окно Excel
    Dim hWnd As LongPtr
    Dim windowName As String
        windowName = Application.Caption
    If Len(windowName) = 0 Then windowName = "Microsoft Excel"
        hWnd = FindWindow("XLMAIN", windowName)
    If hWnd <> 0 Then
        ShowWindow hWnd, SW_SHOW
    End If
End Sub
Public Sub AutoOpen()
    ' Альтернатива Workbook_Open для надстроек
    ThisWorkbook.Windows(1).Visible = False
    g_FormIsOpen = True
    UserForm1.Show vbModeless
End Sub

4. Модуль clsAppEvents (для перехвата событий Excel)

Option Explicit
Private WithEvents App As Application
Private WithEvents WorkbookEvents As Workbook
Public Sub Initialize()
    Set App = Application
    Set WorkbookEvents = ThisWorkbook
End Sub
Private Sub App_WorkbookActivate(ByVal Wb As Workbook)
    ' При активации любой книги
    If Wb.Name = ThisWorkbook.Name Then
        ' Если активируется наша книга - скрываем ее
        ThisWorkbook.Windows(1).Visible = False
        If UserForm1.Visible Then
            UserForm1.SetFocus
        End If
    End If
End Sub
Private Sub App_WindowActivate(ByVal Wb As Workbook, ByVal Wn As Window)
    ' При активации любого окна
    If Not Wb Is Nothing Then
        If Wb.Name = ThisWorkbook.Name Then
            Wn.Visible = False
            If UserForm1.Visible Then
                UserForm1.SetFocus
            End If
        End If
    End If
End Sub
Private Sub WorkbookEvents_WindowActivate(ByVal Wn As Window)
    ' При активации окна нашей книги
    Wn.Visible = False
    If UserForm1.Visible Then
        UserForm1.SetFocus
    End If
End Sub

5. Модуль modGlobal для инициализации

Option Explicit
Public AppHandler As clsAppEvents
Sub InitializeApp()
    ' Инициализация обработчика событий
    Set AppHandler = New clsAppEvents
    AppHandler.Initialize
End Sub
Sub CleanUp()
    ' Очистка перед закрытием
    On Error Resume Next
    Set AppHandler = Nothing
End Sub
Дополнительные настройки формы
Добавьте на форму элементы управления.
Вот пример формы с кнопками:
' В UserForm1 добавьте этот код
Private Sub UserForm_Initialize()
    With Me
        .Caption = "Управляющая панель"
        .Width = 400
        .Height = 300
                ' Создаем элементы динамически или в дизайнере
        ' Пример кнопки
        Dim btn As MSForms.CommandButton
        Set btn = Me.Controls.Add("Forms.CommandButton.1", "btnTest", True)
        With btn
            .Caption = "Тестовая кнопка"
            .Left = 20
            .Top = 20
            .Width = 100
            .Height = 25
        End With
                ' Кнопка закрытия
        Dim btnClose As MSForms.CommandButton
        Set btnClose = Me.Controls.Add("Forms.CommandButton.1", "btnClose", True)
        With btnClose
            .Caption = "Закрыть"
            .Left = 20
            .Top = 240
            .Width = 100
            .Height = 25
        End With
    End With
End Sub
' Обработчик нажатия кнопки (создается автоматически при двойном клике на кнопке в дизайнере)
Private Sub btnClose_Click()
    Unload Me
End Sub
Private Sub btnTest_Click()
    MsgBox "Тестовая функция выполнена!", vbInformation
End Sub

Код для предотвращения показа книги
Добавьте в ThisWorkbook:

Private Sub Workbook_WindowActivate(ByVal Wn As Window)
    ' При активации окна книги скрываем его
    If UserForm1.Visible Then
        Wn.Visible = False
        Application.OnTime Now + TimeValue("00:00:00.1"), "ActivateForm"
    End If
End Sub

Добавьте в стандартный модуль:

Public Sub ActivateForm()
    ' Активируем форму
    On Error Resume Next
    UserForm1.SetFocus
End Sub
Public Sub PreventWorkbookActivation()
    ' Постоянно проверяем и скрываем книгу
    Do While UserForm1.Visible
        ThisWorkbook.Windows(1).Visible = False
        DoEvents
        Sleep 100 ' Пауза 0.1 секунды
    Loop
End Sub
#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Автозапуск формы при открытии файла
Добавьте в стандартный модуль:

Public Sub Auto_Open()
    ' Для совместимости со старыми версиями
    Call Workbook_Open
End Sub
Public Sub Workbook_Open()
    ' Основная процедура открытия
    Application.ScreenUpdating = False
    Application.EnableEvents = False
        ' Скрываем книгу
    ThisWorkbook.Windows(1).Visible = False
    ThisWorkbook.Windows(1).WindowState = xlMinimized
        ' Инициализируем события
    Call InitializeApp
        ' Показываем форму
    UserForm1.Show vbModeless
        Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Файл с примером структуры
Создайте файл HiddenWorkbook.xlsm со следующей структурой:
HiddenWorkbook.xlsm
├── ThisWorkbook (VBAProject)
├── UserForm1 (UserForm)
├── Module1 (Standard Module)
├── Module2 (Standard Module)
├── clsAppEvents (Class Module)
└── modGlobal (Standard Module)

Проверка на разных компьютерах
Чтобы код работал на разных ПК независимо от настроек:
Отключите проверку надстроек:

Private Sub Workbook_Open()
    On Error Resume Next
    Application.AddIns("Личная книга макросов").Installed = False
    ' ... остальной код
End Sub
Используйте абсолютные пути:vba
Private Function GetAppPath() As String
    GetAppPath = ThisWorkbook.Path
End Function
Обрабатывайте ошибки:
Private Sub Workbook_Open()
    On Error GoTo ErrorHandler
    ' ... код инициализации
    Exit Sub    
ErrorHandler:
    ' Показываем форму даже при ошибках
    UserForm1.Show vbModeless
    ThisWorkbook.Windows(1).Visible = False
End Sub

Тестирование
Для тестирования создайте макрос:

Sub TestWorkbookVisibility()
    ' Проверяем видимость книги
    MsgBox "Видимость окна книги: " & ThisWorkbook.Windows(1).Visible
    MsgBox "Видимость формы: " & UserForm1.Visible
End Sub

Важные замечания
Форма не модальная - можно работать с другими файлами Excel
При закрытии формы книга закроется автоматически
Книга всегда скрыта - даже при открытии других файлов
Не зависит от надстроек - код работает в любом окружении
API-вызовы скрывают окно на системном уровне
Это решение обеспечивает полную изоляцию формы от книги и стабильную работу на любом ПК с Excel 2010 и выше.

    picPath = "C:\картинка.jpg"    
' Вставляем как ссылку
    Set pic = ActiveSheet.Pictures.Insert(picPath)    
' Сохраняем путь в свойстве объекта (Alt-текст)
    pic.ShapeRange.AlternativeText = picPath

Option Explicit

' API для GDI+ (для работы с изображениями)
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type

Private Type PICTDESC
    cbSizeOfStruct As Long
    picType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type

Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" ( _
    token As Long, _
    inputbuf As GdiplusStartupInput, _
    Optional ByVal outputbuf As Long = 0) As Long
    
Private Declare PtrSafe Sub GdiplusShutdown Lib "gdiplus" ( _
    ByVal token As Long)
    
Private Declare PtrSafe Function GdipLoadImageFromFile Lib "gdiplus" ( _
    ByVal FileName As Long, _
    hImage As Long) As Long
    
Private Declare PtrSafe Function GdipCreateFromHDC Lib "gdiplus" ( _
    ByVal hdc As Long, _
    graphics As Long) As Long
    
Private Declare PtrSafe Function GdipDrawImageRectI Lib "gdiplus" ( _
    ByVal graphics As Long, _
    ByVal hImage As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal Width As Long, _
    ByVal Height As Long) As Long
    
Private Declare PtrSafe Function GdipGetImageWidth Lib "gdiplus" ( _
    ByVal hImage As Long, _
    Width As Long) As Long
    
Private Declare PtrSafe Function GdipGetImageHeight Lib "gdiplus" ( _
    ByVal hImage As Long, _
    Height As Long) As Long
    
Private Declare PtrSafe Function GdipCreateBitmapFromScan0 Lib "gdiplus" ( _
    ByVal Width As Long, _
    ByVal Height As Long, _
    ByVal stride As Long, _
    ByVal PixelFormat As Long, _
    scan0 As Any, _
    BITMAP As Long) As Long
    
Private Declare PtrSafe Function GdipGetImagePixelFormat Lib "gdiplus" ( _
    ByVal hImage As Long, _
    PixelFormat As Long) As Long
    
Private Declare PtrSafe Function GdipBitmapLockBits Lib "gdiplus" ( _
    ByVal BITMAP As Long, _
    RECT As RECTL, _
    ByVal flags As Long, _
    ByVal PixelFormat As Long, _
    LockedBitmapData As BitmapData) As Long
    
Private Declare PtrSafe Function GdipBitmapUnlockBits Lib "gdiplus" ( _
    ByVal BITMAP As Long, _
    LockedBitmapData As BitmapData) As Long
    
Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" ( _
    ByVal hImage As Long) As Long
    
Private Declare PtrSafe Function GdipGraphicsClear Lib "gdiplus" ( _
    ByVal graphics As Long, _
    ByVal argb As Long) As Long
    
Private Declare PtrSafe Function GdipDeleteGraphics Lib "gdiplus" ( _
    ByVal graphics As Long) As Long
    
Private Type RECTL
    Left As Long
    Top As Long
    Width As Long
    Height As Long
End Type

Private Type BitmapData
    Width As Long
    Height As Long
    stride As Long
    PixelFormat As Long
    scan0 As Long
    Reserved As Long
End Type

Private Type ProcessedImageData
    Histogram(0 To 255) As Double
    RowAverages() As Double
    ColAverages() As Double
    Signature(0 To 3) As Double
    FilePath As String
    Width As Long
    Height As Long
End Type

' Константы
Private Const IMAGE_SIZE As Integer = 32 ' Размер для ресайза
Private Const PixelFormat32bppRGB As Long = &H221000
Private Const PixelFormat32bppARGB As Long = &H26200A
Private Const ImageLockModeRead As Long = &H1
Private Const ImageLockModeWrite As Long = &H2
Private Const UnitPixel As Long = 2

' Глобальные переменные
Private gToken As Long
Private cachedReferences As Object ' Для кэширования эталонных изображений
Private comparisonLog As Collection ' Для логирования

' Основные типы данных
Private Type ComparisonResult
    FilePath As String
    BestMatch As String
    Confidence As Double
    TopCandidates As Collection
    IsConfident As Boolean
End Type

' Инициализация GDI+
Private Sub InitializeGDIplus()
    Dim gdiSI As GdiplusStartupInput
    gdiSI.GdiplusVersion = 1
    If GdiplusStartup(gToken, gdiSI) <> 0 Then
        MsgBox "Ошибка инициализации GDI+", vbCritical
        End
    End If
End Sub

' Загрузка и обработка изображения
Private Function LoadAndProcessImage(imgPath As String) As ProcessedImageData
    Dim hImage As Long
    Dim imgWidth As Long, imgHeight As Long
    Dim processedData As ProcessedImageData
    Dim i As Long, j As Long
    Dim pixelData() As Byte
    Dim hist(0 To 255) As Long
    Dim totalPixels As Long
    
    ' Инициализация GDI+ при первом вызове
    If gToken = 0 Then InitializeGDIplus
    
    ' Загрузка изображения
    If GdipLoadImageFromFile(StrPtr(imgPath), hImage) <> 0 Then
        MsgBox "Ошибка загрузки изображения: " & imgPath, vbCritical
        Exit Function
    End If
    
    ' Получение размеров
    GdipGetImageWidth hImage, imgWidth
    GdipGetImageHeight hImage, imgHeight
    
    ' Создание уменьшенной версии изображения
    Dim resizedPixels() As Byte
    resizedPixels = ResizeImageToArray(hImage, imgWidth, imgHeight, IMAGE_SIZE, IMAGE_SIZE)
    
    ' Преобразование в оттенки серого и вычисление гистограммы
    Dim grayValue As Integer
    Dim sumBrightness As Double
    totalPixels = IMAGE_SIZE * IMAGE_SIZE
    
    ReDim processedData.RowAverages(0 To IMAGE_SIZE - 1)
    ReDim processedData.ColAverages(0 To IMAGE_SIZE - 1)
    
    ' Матрица для расчета
    Dim pixelMatrix(0 To IMAGE_SIZE - 1, 0 To IMAGE_SIZE - 1) As Double
    
    For i = 0 To IMAGE_SIZE - 1
        For j = 0 To IMAGE_SIZE - 1
            ' Индекс в массиве (каждый пиксель = 4 байта: BGRA)
            Dim idx As Long
            idx = (i * IMAGE_SIZE + j) * 4
            
            ' Преобразование в оттенки серого
            Dim r As Long, g As Long, b As Long
            b = resizedPixels(idx)
            g = resizedPixels(idx + 1)
            r = resizedPixels(idx + 2)
            
            grayValue = (r * 0.299 + g * 0.587 + b * 0.114)
            If grayValue > 255 Then grayValue = 255
            If grayValue < 0 Then grayValue = 0
            
            ' Запись в матрицу
            pixelMatrix(i, j) = grayValue / 255
            
            ' Обновление гистограммы
            hist(grayValue) = hist(grayValue) + 1
        Next j
    Next i
    
    ' Нормализация гистограммы
    For i = 0 To 255
        processedData.Histogram(i) = hist(i) / totalPixels
    Next i
    
    ' Вычисление средних по строкам и столбцам
    For i = 0 To IMAGE_SIZE - 1
        Dim rowSum As Double, colSum As Double
        rowSum = 0
        colSum = 0
        
        For j = 0 To IMAGE_SIZE - 1
            rowSum = rowSum + pixelMatrix(i, j)
            colSum = colSum + pixelMatrix(j, i)
        Next j
        
        processedData.RowAverages(i) = rowSum / IMAGE_SIZE
        processedData.ColAverages(i) = colSum / IMAGE_SIZE
    Next i
    
    ' Вычисление сигнатуры (4 квадранта)
    Dim quadSize As Long
    quadSize = IMAGE_SIZE / 2
    
    For i = 0 To 3
        Dim quadSum As Double
        quadSum = 0
        Dim startRow As Long, startCol As Long
        
        Select Case i
            Case 0 ' Левый верхний
                startRow = 0: startCol = 0
            Case 1 ' Правый верхний
                startRow = 0: startCol = quadSize
            Case 2 ' Левый нижний
                startRow = quadSize: startCol = 0
            Case 3 ' Правый нижний
                startRow = quadSize: startCol = quadSize
        End Select
        
        For j = 0 To quadSize - 1
            For k = 0 To quadSize - 1
                quadSum = quadSum + pixelMatrix(startRow + j, startCol + k)
            Next k
        Next j
        
        processedData.Signature(i) = quadSum / (quadSize * quadSize)
    Next i
    
    ' Сохранение дополнительной информации
    processedData.FilePath = imgPath
    processedData.Width = imgWidth
    processedData.Height = imgHeight
    
    ' Освобождение ресурсов
    GdipDisposeImage hImage
    
    LoadAndProcessImage = processedData
End Function

' Функция для изменения размера изображения и получения массива пикселей
Private Function ResizeImageToArray(hImage As Long, srcWidth As Long, srcHeight As Long, _
                                   newWidth As Long, newHeight As Long) As Byte()
    Dim hBitmap As Long
    Dim bitmapData As BitmapData
    Dim rect As RECTL
    Dim pixelBytes() As Byte
    
    ' Создание нового bitmap нужного размера
    GdipCreateBitmapFromScan0 newWidth, newHeight, 0, PixelFormat32bppARGB, ByVal 0&, hBitmap
    
    ' Создание графического контекста
    Dim hGraphics As Long
    GdipCreateFromHDC 0, hGraphics
    
    ' Очистка и рисование
    GdipGraphicsClear hGraphics, &HFFFFFFFF
    GdipDrawImageRectI hGraphics, hImage, 0, 0, newWidth, newHeight
    
    ' Блокировка битов для чтения
    rect.Left = 0
    rect.Top = 0
    rect.Width = newWidth
    rect.Height = newHeight
    
    GdipBitmapLockBits hBitmap, rect, ImageLockModeRead, PixelFormat32bppARGB, bitmapData
    
    ' Копирование данных
    ReDim pixelBytes(0 To bitmapData.stride * newHeight - 1)
    CopyMemory pixelBytes(0), ByVal bitmapData.scan0, UBound(pixelBytes) + 1
    
    ' Разблокировка
    GdipBitmapUnlockBits hBitmap, bitmapData
    
    ' Очистка
    GdipDeleteGraphics hGraphics
    GdipDisposeImage hBitmap
    
    ResizeImageToArray = pixelBytes
End Function

' Сравнение гистограмм (корреляция)
Private Function CompareHistograms(hist1() As Double, hist2() As Double) As Double
    Dim i As Long
    Dim sum1 As Double, sum2 As Double
    Dim sum12 As Double
    Dim sum1Sq As Double, sum2Sq As Double
    
    For i = 0 To 255
        sum1 = sum1 + hist1(i)
        sum2 = sum2 + hist2(i)
        sum12 = sum12 + hist1(i) * hist2(i)
        sum1Sq = sum1Sq + hist1(i) * hist1(i)
        sum2Sq = sum2Sq + hist2(i) * hist2(i)
    Next i
    
    Dim numerator As Double
    Dim denominator As Double
    
    numerator = sum12 - (sum1 * sum2 / 256)
    denominator = Sqr((sum1Sq - sum1 * sum1 / 256) * (sum2Sq - sum2 * sum2 / 256))
    
    If denominator <> 0 Then
        CompareHistograms = numerator / denominator
    Else
        CompareHistograms = 0
    End If
End Function

' Сравнение массивов (1 - нормализованное евклидово расстояние)
Private Function CompareArrays(arr1() As Double, arr2() As Double) As Double
    Dim i As Long
    Dim sumSqDiff As Double
    Dim maxDiff As Double
    
    For i = LBound(arr1) To UBound(arr1)
        sumSqDiff = sumSqDiff + (arr1(i) - arr2(i)) ^ 2
    Next i
    
    ' Нормализация: 1 - sqrt(sumSqDiff)/max_possible
    ' Максимальное различие при сравнении: каждый элемент = 1
    maxDiff = Sqr(UBound(arr1) - LBound(arr1) + 1)
    
    If maxDiff > 0 Then
        CompareArrays = 1 - (Sqr(sumSqDiff) / maxDiff)
    Else
        CompareArrays = 0
    End If
End Function

' Сравнение сигнатур
Private Function CompareSignatures(sig1() As Double, sig2() As Double) As Double
    Dim i As Long
    Dim sumDiff As Double
    
    For i = LBound(sig1) To UBound(sig1)
        sumDiff = sumDiff + Abs(sig1(i) - sig2(i))
    Next i
    
    ' 1 - нормализованная сумма разниц
    CompareSignatures = 1 - (sumDiff / (UBound(sig1) - LBound(sig1) + 1))
End Function

' Основная функция сравнения
Private Function CompareImages(imgPath1 As String, imgPath2 As String) As Double
    Dim data1 As ProcessedImageData
    Dim data2 As ProcessedImageData
    
    ' Кэширование обработки изображений
    If cachedReferences Is Nothing Then
        Set cachedReferences = CreateObject("Scripting.Dictionary")
    End If
    
    ' Получение или обработка первого изображения
    If cachedReferences.Exists(imgPath1) Then
        data1 = cachedReferences(imgPath1)
    Else
        data1 = LoadAndProcessImage(imgPath1)
        cachedReferences.Add imgPath1, data1
    End If
    
    ' Получение или обработка второго изображения
    If cachedReferences.Exists(imgPath2) Then
        data2 = cachedReferences(imgPath2)
    Else
        data2 = LoadAndProcessImage(imgPath2)
        cachedReferences.Add imgPath2, data2
    End If
    
    ' Вычисление метрик
    Dim scoreHist As Double
    Dim scoreRows As Double
    Dim scoreCols As Double
    Dim scoreSig As Double
    
    scoreHist = CompareHistograms(data1.Histogram, data2.Histogram)
    scoreRows = CompareArrays(data1.RowAverages, data2.RowAverages)
    scoreCols = CompareArrays(data1.ColAverages, data2.ColAverages)
    scoreSig = CompareSignatures(data1.Signature, data2.Signature)
    
    ' Взвешенное среднее (можно настроить)
    Dim finalScore As Double
    finalScore = (scoreHist * 0.3) + (scoreRows * 0.25) + _
                 (scoreCols * 0.25) + (scoreSig * 0.2)
    
    ' Ограничение от 0 до 1
    If finalScore < 0 Then finalScore = 0
    If finalScore > 1 Then finalScore = 1
    
    CompareImages = finalScore
End Function

' Поиск лучшего соответствия для изображения
Private Function FindBestMatch(newImagePath As String, referencePaths As Collection, _
                              ByRef confidence As Double, ByRef isConfident As Boolean) As String
    Dim bestMatch As String
    Dim bestScore As Double
    Dim secondBestScore As Double
    Dim refPath As Variant
    Dim score As Double
    
    bestScore = 0
    secondBestScore = 0
    bestMatch = ""
    
    ' Для логирования
    Dim logEntry As String
    Dim scoresDict As Object
    Set scoresDict = CreateObject("Scripting.Dictionary")
    
    ' Поиск по всем эталонным изображениям
    For Each refPath In referencePaths
        score = CompareImages(newImagePath, refPath)
        scoresDict.Add refPath, score
        
        ' Обновление лучших результатов
        If score > bestScore Then
            secondBestScore = bestScore
            bestScore = score
            bestMatch = refPath
        ElseIf score > secondBestScore Then
            secondBestScore = score
        End If
    Next refPath
    
    ' Расчет уверенности
    confidence = bestScore
    
    ' Критерии уверенности
    Const CONFIDENCE_THRESHOLD As Double = 0.7
    Const GAP_THRESHOLD As Double = 0.15
    
    If bestScore >= CONFIDENCE_THRESHOLD And _
       (bestScore - secondBestScore) >= GAP_THRESHOLD Then
        isConfident = True
    Else
        isConfident = False
    End If
    
    ' Логирование
    logEntry = "Изображение: " & newImagePath & vbCrLf
    logEntry = logEntry & "Лучшее совпадение: " & bestMatch & vbCrLf
    logEntry = logEntry & "Оценка: " & Format(bestScore, "0.000") & vbCrLf
    logEntry = logEntry & "Второе лучшее: " & Format(secondBestScore, "0.000") & vbCrLf
    logEntry = logEntry & "Уверенность: " & IIf(isConfident, "ВЫСОКАЯ", "НИЗКАЯ") & vbCrLf
    
    ' Топ-5 кандидатов для логирования
    logEntry = logEntry & "Топ-5 кандидатов:" & vbCrLf
    Dim sortedPaths As Variant
    sortedPaths = GetTopCandidates(scoresDict, 5)
    
    For i = 0 To UBound(sortedPaths)
        logEntry = logEntry & "  " & sortedPaths(i, 0) & ": " & _
                   Format(sortedPaths(i, 1), "0.000") & vbCrLf
    Next i
    
    logEntry = logEntry & "----------------------------------------" & vbCrLf
    comparisonLog.Add logEntry
    
    FindBestMatch = bestMatch
End Function

' Получение топ-N кандидатов
Private Function GetTopCandidates(scoresDict As Object, topN As Long) As Variant
    Dim keys As Variant
    Dim values As Variant
    Dim i As Long, j As Long
    Dim tempKey As String
    Dim tempValue As Double
    
    keys = scoresDict.Keys
    values = scoresDict.Items
    
    ' Простая сортировка пузырьком
    For i = 0 To UBound(keys) - 1
        For j = i + 1 To UBound(keys)
            If values(j) > values(i) Then
                ' Обмен ключами
                tempKey = keys(i)
                keys(i) = keys(j)
                keys(j) = tempKey
                
                ' Обмен значениями
                tempValue = values(i)
                values(i) = values(j)
                values(j) = tempValue
            End If
        Next j
    Next i
    
    ' Возвращаем топ-N
    Dim result() As Variant
    ReDim result(0 To Application.Min(topN - 1, UBound(keys)), 0 To 1)
    
    For i = 0 To UBound(result, 1)
        result(i, 0) = keys(i)
        result(i, 1) = values(i)
    Next i
    
    GetTopCandidates = result
End Function

' Основной макрос для анализа
Sub ЗапуститьОбщийАнализ()
    Dim startTime As Double
    startTime = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' Инициализация
    If gToken = 0 Then InitializeGDIplus
    Set cachedReferences = CreateObject("Scripting.Dictionary")
    Set comparisonLog = New Collection
    
    ' Очистка листа логов если он существует
    On Error Resume Next
    ThisWorkbook.Sheets("Логирование").Delete
    On Error GoTo 0
    
    ' Создание листа для логов
    Dim logSheet As Worksheet
    Set logSheet = ThisWorkbook.Sheets.Add
    logSheet.Name = "Логирование"
    
    ' Заголовки для логов
    logSheet.Range("A1").Value = "ЛОГ СРАВНЕНИЯ ИЗОБРАЖЕНИЙ"
    logSheet.Range("A1").Font.Bold = True
    logSheet.Range("A1").Font.Size = 14
    
    ' Получение списков изображений
    Dim newImages As Collection
    Dim refImages As Collection
    Set newImages = GetImageList("A", "Список")
    Set refImages = GetImageList("B", "Список")
    
    If newImages.Count = 0 Or refImages.Count = 0 Then
        MsgBox "Не найдены изображения для сравнения!", vbExclamation
        Exit Sub
    End If
    
    ' Обработка новых изображений
    Dim newImage As Variant
    Dim results As Collection
    Set results = New Collection
    
    Dim processedCount As Long
    processedCount = 0
    
    For Each newImage In newImages
        Dim result As ComparisonResult
        Dim confidence As Double
        Dim isConfident As Boolean
        
        result.FilePath = newImage
        result.BestMatch = FindBestMatch(newImage, refImages, confidence, isConfident)
        result.Confidence = confidence
        result.IsConfident = isConfident
        
        results.Add result
        
        processedCount = processedCount + 1
        Application.StatusBar = "Обработано: " & processedCount & " из " & newImages.Count
        DoEvents
    Next newImage
    
    ' Запись логов на лист
    Dim logRow As Long
    logRow = 3
    
    For Each logEntry In comparisonLog
        logSheet.Cells(logRow, 1).Value = logEntry
        logRow = logRow + 1
    Next logEntry
    
    ' Запись результатов
    logRow = logRow + 2
    logSheet.Cells(logRow, 1).Value = "ИТОГОВЫЕ РЕЗУЛЬТАТЫ"
    logSheet.Cells(logRow, 1).Font.Bold = True
    logRow = logRow + 1
    
    Dim confidentCount As Long
    confidentCount = 0
    
    For Each result In results
        logSheet.Cells(logRow, 1).Value = result.FilePath
        logSheet.Cells(logRow, 2).Value = result.BestMatch
        logSheet.Cells(logRow, 3).Value = Format(result.Confidence, "0.000")
        logSheet.Cells(logRow, 4).Value = IIf(result.IsConfident, "ДА", "НЕТ")
        
        If result.IsConfident Then confidentCount = confidentCount + 1
        logRow = logRow + 1
    Next result
    
    ' Итоговая статистика
    logRow = logRow + 1
    logSheet.Cells(logRow, 1).Value = "СТАТИСТИКА:"
    logRow = logRow + 1
    logSheet.Cells(logRow, 1).Value = "Всего обработано:"
    logSheet.Cells(logRow, 2).Value = newImages.Count
    logRow = logRow + 1
    logSheet.Cells(logRow, 1).Value = "С высокой уверенностью:"
    logSheet.Cells(logRow, 2).Value = confidentCount
    logRow = logRow + 1
    logSheet.Cells(logRow, 1).Value = "Процент успеха:"
    logSheet.Cells(logRow, 2).Value = Format(confidentCount / newImages.Count * 100, "0.0") & "%"
    
    ' Авто-подгон ширины столбцов
    logSheet.Columns.AutoFit
    
    Application.StatusBar = False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    Dim elapsedTime As Double
    elapsedTime = Timer - startTime
    
    MsgBox "Анализ завершен!" & vbCrLf & _
           "Обработано изображений: " & newImages.Count & vbCrLf & _
           "С высокой уверенностью: " & confidentCount & vbCrLf & _
           "Время выполнения: " & Format(elapsedTime, "0.0") & " сек", _
           vbInformation, "Результаты"
End Sub

' Макрос для копирования и переименования изображений
Sub СравнитьИНазватьИзСписка()
    Dim startTime As Double
    startTime = Timer
    
    Application.ScreenUpdating = False
    
    ' Проверка наличия листа с результатами
    On Error Resume Next
    Dim logSheet As Worksheet
    Set logSheet = ThisWorkbook.Sheets("Логирование")
    On Error GoTo 0
    
    If logSheet Is Nothing Then
        MsgBox "Сначала выполните анализ изображений!", vbExclamation
        Exit Sub
    End If
    
    ' Поиск раздела с результатами
    Dim lastRow As Long
    lastRow = logSheet.Cells(logSheet.Rows.Count, 1).End(xlUp).Row
    
    Dim resultsStart As Long
    For resultsStart = 1 To lastRow
        If logSheet.Cells(resultsStart, 1).Value = "ИТОГОВЫЕ РЕЗУЛЬТАТЫ" Then
            Exit For
        End If
    Next resultsStart
    
    If resultsStart > lastRow Then
        MsgBox "Не найден раздел с результатами!", vbExclamation
        Exit Sub
    End If
    
    ' Создание папки "Готовые"
    Dim outputFolder As String
    outputFolder = ThisWorkbook.Path & "\Готовые\"
    
    On Error Resume Next
    MkDir outputFolder
    On Error GoTo 0
    
    ' Копирование и переименование
    Dim i As Long
    Dim srcPath As String, dstPath As String
    Dim origName As String, newName As String
    Dim confidence As Double
    Dim isConfident As Boolean
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim copiedCount As Long
    Dim skippedCount As Long
    copiedCount = 0
    skippedCount = 0
    
    For i = resultsStart + 2 To lastRow
        If logSheet.Cells(i, 1).Value = "" Then Exit For
        
        srcPath = logSheet.Cells(i, 1).Value
        origName = fso.GetFileName(srcPath)
        
        ' Проверка уверенности
        isConfident = (logSheet.Cells(i, 4).Value = "ДА")
        
        If isConfident Then
            ' Формирование нового имени
            Dim bestMatch As String
            bestMatch = logSheet.Cells(i, 2).Value
            
            If bestMatch <> "" Then
                ' Используем имя эталонного файла
                newName = fso.GetFileName(bestMatch)
                dstPath = outputFolder & newName
                
                ' Проверка на дубликаты
                Dim counter As Long
                counter = 1
                Dim baseName As String, ext As String
                
                baseName = fso.GetBaseName(newName)
                ext = fso.GetExtensionName(newName)
                
                While fso.FileExists(dstPath)
                    newName = baseName & "_" & counter & "." & ext
                    dstPath = outputFolder & newName
                    counter = counter + 1
                Wend
                
                ' Копирование файла
                fso.CopyFile srcPath, dstPath, True
                copiedCount = copiedCount + 1
            Else
                skippedCount = skippedCount + 1
            End If
        Else
            ' Для изображений с низкой уверенностью - копируем с отметкой
            newName = "НЕУВЕРЕННО_" & origName
            dstPath = outputFolder & newName
            
            ' Проверка на дубликаты
            Dim counter2 As Long
            counter2 = 1
            Dim baseName2 As String, ext2 As String
            
            baseName2 = fso.GetBaseName(newName)
            ext2 = fso.GetExtensionName(newName)
            
            While fso.FileExists(dstPath)
                newName = baseName2 & "_" & counter2 & "." & ext2
                dstPath = outputFolder & newName
                counter2 = counter2 + 1
            Wend
            
            fso.CopyFile srcPath, dstPath, True
            skippedCount = skippedCount + 1
        End If
    Next i
    
    Application.ScreenUpdating = True
    
    Dim elapsedTime As Double
    elapsedTime = Timer - startTime
    
    MsgBox "Копирование завершено!" & vbCrLf & _
           "Успешно переименовано: " & copiedCount & vbCrLf & _
           "С низкой уверенностью: " & skippedCount & vbCrLf & _
           "Время выполнения: " & Format(elapsedTime, "0.0") & " сек" & vbCrLf & _
           "Файлы сохранены в: " & outputFolder, _
           vbInformation, "Результаты"
End Sub

' Вспомогательная функция для получения списка изображений
Private Function GetImageList(columnLetter As String, sheetName As String) As Collection
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(sheetName)
    
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, columnLetter).End(xlUp).Row
    
    Dim col As New Collection
    Dim i As Long
    Dim filePath As String
    
    For i = 1 To lastRow
        filePath = Trim(ws.Cells(i, columnLetter).Value)
        If filePath <> "" And Dir(filePath) <> "" Then
            col.Add filePath
        End If
    Next i
    
    Set GetImageList = col
End Function

' Функция для ручной настройки параметров
Sub НастройкаПараметров()
    Dim response As String
    
    response = InputBox("Настройка параметров сравнения:" & vbCrLf & _
                       "1. Порог уверенности (0.0-1.0)" & vbCrLf & _
                       "2. Минимальный разрыв между лучшими" & vbCrLf & _
                       "3. Размер изображения для анализа" & vbCrLf & vbCrLf & _
                       "Введите значения через запятую:" & vbCrLf & _
                       "(по умолчанию: 0.7,0.15,32)", _
                       "Настройка параметров", "0.7,0.15,32")
    
    If response <> "" Then
        Dim params() As String
        params = Split(response, ",")
        
        If UBound(params) >= 2 Then
            MsgBox "Параметры установлены:" & vbCrLf & _
                   "Порог уверенности: " & params(0) & vbCrLf & _
                   "Минимальный разрыв: " & params(1) & vbCrLf & _
                   "Размер изображения: " & params(2) & "x" & params(2), _
                   vbInformation
        End If
    End If
End Sub

' Очистка кэша
Sub ОчиститьКэш()
    Set cachedReferences = Nothing
    MsgBox "Кэш очищен", vbInformation
End Sub

' Выход из GDI+ при закрытии
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    If gToken <> 0 Then
        GdiplusShutdown gToken
        gToken = 0
    End If
End Sub

=ФИЛЬТР(ЕСЛИ(ЕФОРМУЛА($B$3:$B$10);"красный";"");$C$3:$C$10<>"")
=ЕСЛИОШИБКА(ФИЛЬТР(ПСТР(Ф.ТЕКСТ($B$3:$B$10);ПОИСК("Ч";Ф.ТЕКСТ($B$3:$B$10))+1;100);$C$3:$C$10<>"");"")
=ГСТОЛБИК(ФИЛЬТР($C$3:$C$10;$C$3:$C$10<>"");
ЕСЛИОШИБКА(ФИЛЬТР(ПСТР(Ф.ТЕКСТ($B$3:$B$10);ПОИСК("Ч";Ф.ТЕКСТ($B$3:$B$10))+1;100);$C$3:$C$10<>"");""))

=ТЕКСТ(ЦЕЛОЕ(B2/1);"# ##")
=ТЕКСТ(ЦЕЛОЕ(B2/1);"# ##")&" рубл"&ПРОСМОТР(--ПРАВБ(ЦЕЛОЕ(B2/1);1);{0;1;2;5};{"ей";"ь";"я";"ей"})&" "&
ТЕКСТ(ОКРУГЛ(ОСТАТ(B2;1);2)*100;"00")&" копе"&ПРОСМОТР(--ПРАВБ(ОКРУГЛ(ОСТАТ(B2;1);2);1);{0;1;2;5};
{"ек";"йка";"йки";"ек"})

=ИНДЕКС(G3:AK11;СТРОКА(B3:B11)-2;ПОИСКПОЗ(ДЕНЬ(B2);G1:AK1;0))+C3:C11

=ФИЛЬТР.XML("<j><i>"&ПОДСТАВИТЬ(A1;", ";"</i><i>")&"</i></j>";"//i[last()-1]")
=ФИЛЬТР.XML("<j><i>"&ПОДСТАВИТЬ(A1;", ";"</i><i>")&"</i></j>";"//i[last()]")

=МУМНОЖ(F4:AJ12*1;--(СТРОКА(1:31)>0))+B4:B12

=B4:B12+
F4:F12+G4:G12+H4:H12+I4:I12+J4:J12+K4:K12+L4:L12+
M4:M12+N4:N12+O4:O12+P4:P12+Q4:Q12+R4:R12+S4:S12+
T4:T12+U4:U12+V4:V12+W4:W12+X4:X12+Y4:Y12+Z4:Z12+
AA4:AA12+AB4:AB12+AC4:AC12+AD4:AD12+AE4:AE12+AF4:AF12+AG4:AG12+
AH4:AH12+AI4:AI12+AJ4:AJ12