=B1<$A1

Option Explicit

Sub Создать_заголовки()
    CloseEmptyWb
    Dim ActiveWindow_Zoom As Long
    ActiveWindow_Zoom = ActiveWindow.Zoom
    
    CreateHeader sourceRange:=Selection, headerColumn:=1, targetRange:=Workbooks.Add(1).Sheets(1).Cells(1, 1)
    
    ActiveWindow.Zoom = ActiveWindow_Zoom
End Sub

Private Sub CreateHeader(sourceRange As Range, headerColumn As Long, targetRange As Range)
    Set sourceRange = Intersect(sourceRange, sourceRange.Parent.UsedRange)
    Set targetRange = targetRange.Resize(sourceRange.Rows.Count, sourceRange.Columns.Count)
    
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    sourceRange.Copy targetRange
    sourceRange.Copy
    targetRange.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    
    Dim yt As Long
    For yt = targetRange.Rows.Count To 2 Step -1
        If targetRange.Cells(yt, headerColumn).Value <> targetRange.Cells(yt - 1, headerColumn).Value Then
            targetRange.Cells(yt, 1).Select
            targetRange.Cells(yt, 1).EntireRow.Insert
            targetRange.Cells(yt, headerColumn + 1).Value = targetRange.Cells(yt + 1, headerColumn).Value
        End If
    Next
    targetRange.Cells(yt + 1, headerColumn).Resize(targetRange.Rows.Count, 1).ClearContents
    
    Application.Calculation = Application_Calculation
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

Option Explicit

Sub SplitTables()
    SplitRange Selection
End Sub

Private Sub SplitRange(sourceRange As Range)
    On Error Resume Next
    Set sourceRange = Intersect(sourceRange, sourceRange.Parent.UsedRange)
    On Error GoTo 0
    If sourceRange Is Nothing Then Exit Sub
    
    Dim dic As Object
    Set dic = GetHeaderDic(sourceRange.Rows(1))
    If dic Is Nothing Then Exit Sub
    If dic.Count = 0 Then Exit Sub
    
    Dim targetRange As Range
    Set targetRange = sourceRange.CurrentRegion.Cells(1, sourceRange.CurrentRegion.Columns.Count + 3)
    
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    Dim vHeader As Variant
    For Each vHeader In dic.Keys
        CopyHeader vHeader, sourceRange, targetRange
        Set targetRange = targetRange.Cells(1 + sourceRange.Rows.Count + 5, 1)
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Private Sub CopyHeader(ByVal sHeader As String, sourceRange As Range, targetRange As Range)
    Set targetRange = targetRange.Resize(sourceRange.Rows.Count, sourceRange.Columns.Count)
    targetRange.Clear
    
    Dim aSource As Variant, xs As Long, ys As Long
    aSource = sourceRange.Value
    
    Dim xt As Long
    For xs = 2 To UBound(aSource, 2)
        If aSource(1, xs) = sHeader Then
            CopyOneColumn sourceRange, xs, targetRange, xt
        End If
    Next

    If sourceRange.Columns.Count > 2 Then
        Application.DisplayAlerts = False
        targetRange.Cells(1, 2).Resize(1, xt).Merge
        Application.DisplayAlerts = True
    End If

End Sub

Private Sub CopyOneColumn(sourceRange As Range, xs As Long, targetRange As Range, ByRef xt As Long)
    xt = xt + 1
    If xt = 1 Then
        sourceRange.Columns(1).Copy targetRange.Columns(1)
    End If
     
    sourceRange.Columns(xs).Copy targetRange.Columns(1 + xt)
End Sub

Private Function GetHeaderDic(sourceRange As Range) As Object
    If sourceRange.Columns.Count = 1 Then Exit Function
    Dim aSource As Variant, xs As Long
    aSource = sourceRange.Value
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For xs = 2 To UBound(aSource, 2)
        If Not IsEmpty(aSource(1, xs)) Then
            dic(aSource(1, xs)) = Empty
        End If
    Next
    
    Set GetHeaderDic = dic
End Function

Sub Продублировать()
    Workbooks("Книга1").Sheets(1).Range("A1").Value = Workbooks("Книга2").Sheets(1).Range("B2").Value
    Workbooks("Книга1").Sheets(1).Range("A2").Value = Workbooks("Книга2").Sheets(1).Range("B3").Value
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Продублировать
End Sub

Option Explicit
  
Sub Заявка()
Const TABLE_RANGE = "A7:H17"
  
Dim adressTo$, fname$, theme$, Disclaimer As Range, closing_titles As Range
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim rng As Range
  
Set sh = ThisWorkbook.Sheets("Заявка")  ' ссылка на листы в файле, где запустить макрос
  
With Application ' управление настройками программы, окнами, рабочими книгами, выполнение глобальных действий
    .DisplayAlerts = False ' отключение автоматических предупреждений и диалоговых окон
    .EnableEvents = False ' отключение автоматических выполнений событий
    .ScreenUpdating = False ' отключение обновления экрана для ускорения макроса
End With
  
With sh
    .AutoFilterMode = False ' отключение режима автофильтра на активном листе, убирает стрелки раскрывающихся списков из заголовков, но не удаляет сами данные
    .Range(TABLE_RANGE).AutoFilter Field:=2, Criteria1:="<>" ' диапазон таблицы
End With
  
Set rng = sh.Range(TABLE_RANGE).CurrentRegion ' автоматический выбор всей непрерывной области данных (таблицы), примыкающей к ячейке A7, ограниченной пустыми строками и столбцами
  
Dim adressCC As String
  
With sh
    adressTo = .Range("C2").Value ' выбор получателя(лей) сообщения
    adressCC = .Range("C3").Value ' выбор получателя(лей) копии сообщения
    theme = .Range("C4").Value ' выбор темы сообщения
    Set Disclaimer = .Range("A5:C5") ' выбор текста сообщения
    Set closing_titles = .Range("A6:C6")
End With
  
Set OutApp = CreateObject("Outlook.Application") ' создание нового экземпляра (объекта) приложения Microsoft Outlook для управления им из другого приложения (Excel или Word)
Set OutMail = OutApp.CreateItem(0) ' создание нового пустого элемента (письма) в приложении Microsoft Outlook
On Error Resume Next ' обработка игнорирование ошибок
  
Dim YourHTMLBody As String, iStart As Long, iEnd As Long ' вставка подписи в элемент (письмо)
  
YourHTMLBody = RangetoHTML(Disclaimer, sh.Range(TABLE_RANGE), closing_titles)
  
With OutMail ' свойства элемента (письма)
    .To = adressTo ' получатель сообщения
    .CC = adressCC ' получатели копии сообщения
    .BCC = "" ' отправка элемента (письма) только основным получателям
    .Subject = theme
    .BodyFormat = 2 ' формат создаваемого элемента (письма) установить HTML
      
    .HTMLBody = YourHTMLBody
      
    .Display
  
End With
  
If rng.Rows.Count > 1 Then
    Set rng = rng.Cells(2, 2).Resize(rng.Rows.Count - 1, rng.Columns.Count - 1)
    With Sheets("Реестр")
        rng.Copy .Cells(.Rows.Count, 2).End(xlUp).Cells(2, 1)
    End With
End If
  
Set OutMail = Nothing
Set OutApp = Nothing
sh.AutoFilterMode = False
ThisWorkbook.Save
  
With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
  
End Sub
  
Function RangetoHTML(ParamArray arr() As Variant) As String
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
   
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        Dim rSource As Range, vv As Variant, rTarget As Range
        Set rTarget = .Cells(1, 1)
        For Each vv In arr
            Set rSource = vv
            CopyRange rSource, rTarget
        Next
         
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
        
    End With
    
    ' Publish the sheet to an .htm file.
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    
    ' Read all data from the .htm file into the RangetoHTML subroutine.
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    
    ' Close TempWB.
    TempWB.Close savechanges:=False
    
    ' Delete the htm file.
    Kill TempFile
    
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
Private Sub CopyRange(rSource As Range, rTarget As Range)
    ' Copy the range and create a workbook to receive the data.
    Dim targAddress As String
    targAddress = rTarget.Address(0, 0, xlA1)
    
    rSource.Copy
    With rTarget
        .PasteSpecial Paste:=8
        .PasteSpecial xlPasteValues, , False, False
        .PasteSpecial xlPasteFormats, , False, False
        .Select
        
        If IsEmpty(rTarget.Cells(1, 1).Value) Then
            .Columns("A:B").Clear
            .Columns("A:B").Delete
            
'            Dim rr As Range
'            For Each rr In .Rows
'                rr.Resize(1, rSource.Columns.Count).Merge
'            Next
        End If
    End With
    Application.CutCopyMode = False
    
    Set rTarget = Range(targAddress).EntireColumn.Cells(Rows.Count, 1).End(xlUp).Cells(3, 1)
End Sub

=ЕСЛИ(ЕПУСТО([Файл1.xlsx]Лист1!A2);"";[Файл1.xlsx]Лист1!A2)

y = 65*x^(10/37)

Option Explicit
 
Sub Заявка()
Const TABLE_RANGE = "A7:H17"
 
Dim adressTo$, fname$, theme$, Disclaimer As Range
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim rng As Range
 
Set sh = ThisWorkbook.Sheets("Заявка")  ' ссылка на листы в файле, где запустить макрос
 
With Application ' управление настройками программы, окнами, рабочими книгами, выполнение глобальных действий
    .DisplayAlerts = False ' отключение автоматических предупреждений и диалоговых окон
    .EnableEvents = False ' отключение автоматических выполнений событий
    .ScreenUpdating = False ' отключение обновления экрана для ускорения макроса
End With
 
With sh
    .AutoFilterMode = False ' отключение режима автофильтра на активном листе, убирает стрелки раскрывающихся списков из заголовков, но не удаляет сами данные
    .Range(TABLE_RANGE).AutoFilter Field:=2, Criteria1:="<>" ' диапазон таблицы
End With
 
Set rng = sh.Range(TABLE_RANGE).CurrentRegion ' автоматический выбор всей непрерывной области данных (таблицы), примыкающей к ячейке A7, ограниченной пустыми строками и столбцами
 
Dim adressCC As String
 
With sh
    adressTo = .Range("C2").Value ' выбор получателя(лей) сообщения
    adressCC = .Range("C3").Value ' выбор получателя(лей) копии сообщения
    theme = .Range("C4").Value ' выбор темы сообщения
    Set Disclaimer = .Range("C5") ' выбор текста сообщения
End With
 
Set OutApp = CreateObject("Outlook.Application") ' создание нового экземпляра (объекта) приложения Microsoft Outlook для управления им из другого приложения (Excel или Word)
Set OutMail = OutApp.CreateItem(0) ' создание нового пустого элемента (письма) в приложении Microsoft Outlook
On Error Resume Next ' обработка игнорирование ошибок
 
Dim YourHTMLBody As String, iStart As Long, iEnd As Long ' вставка подписи в элемент (письмо)
 
YourHTMLBody = RangetoHTML(Disclaimer, sh.Range(TABLE_RANGE))
 
With OutMail ' свойства элемента (письма)
    .To = adressTo ' получатель сообщения
    .CC = adressCC ' получатели копии сообщения
    .BCC = "" ' отправка элемента (письма) только основным получателям
    .Subject = theme
    .BodyFormat = 2 ' формат создаваемого элемента (письма) установить HTML
     
    .HTMLBody = YourHTMLBody
     
    .Display
 
End With
 
If rng.Rows.Count > 1 Then
    Set rng = rng.Cells(2, 2).Resize(rng.Rows.Count - 1, rng.Columns.Count - 1)
    With Sheets("Реестр")
        rng.Copy .Cells(.Rows.Count, 2).End(xlUp).Cells(2, 1)
    End With
End If
 
Set OutMail = Nothing
Set OutApp = Nothing
sh.AutoFilterMode = False
ThisWorkbook.Save
 
With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
 
End Sub
 
Function RangetoHTML(head As Range, rng As Range) As String
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
  
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
   
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        CopyRange head, .Cells(1, 1)
        CopyRange rng, .Cells(3, 1)
        
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
   
    ' Publish the sheet to an .htm file.
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
   
    ' Read all data from the .htm file into the RangetoHTML subroutine.
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
   
    ' Close TempWB.
    TempWB.Close savechanges:=False
   
    ' Delete the htm file.
    Kill TempFile
   
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
Private Sub CopyRange(rSource As Range, rTarget As Range)
    ' Copy the range and create a workbook to receive the data.
    rSource.Copy
    With rTarget
        .PasteSpecial Paste:=8
        .PasteSpecial xlPasteValues, , False, False
        .PasteSpecial xlPasteFormats, , False, False
        .Select
    End With
    Application.CutCopyMode = False
End Sub

=(МАКС(23:23)-B22)/СТЕПЕНЬ(10;ЦЕЛОЕ(LOG10(СЧЁТЗ(23:23)))+1)+B23
=РАНГ(B24;24:24;0)

Option Explicit

Sub Заявка()
Const TABLE_RANGE = "A7:H17"

Dim adressTo$, fname$, theme$, Disclaimer$
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim rng As Range

Set sh = ThisWorkbook.Sheets("Заявка")  ' ссылка на листы в файле, где запустить макрос

With Application ' управление настройками программы, окнами, рабочими книгами, выполнение глобальных действий
    .DisplayAlerts = False ' отключение автоматических предупреждений и диалоговых окон
    .EnableEvents = False ' отключение автоматических выполнений событий
    .ScreenUpdating = False ' отключение обновления экрана для ускорения макроса
End With

With sh
    .AutoFilterMode = False ' отключение режима автофильтра на активном листе, убирает стрелки раскрывающихся списков из заголовков, но не удаляет сами данные
    .Range(TABLE_RANGE).AutoFilter Field:=2, Criteria1:="<>" ' диапазон таблицы
End With

Set rng = sh.Range(TABLE_RANGE).CurrentRegion ' автоматический выбор всей непрерывной области данных (таблицы), примыкающей к ячейке A7, ограниченной пустыми строками и столбцами

Dim adressCC As String

With sh
    adressTo = .Range("C2").Value ' выбор получателя(лей) сообщения
    adressCC = .Range("C3").Value ' выбор получателя(лей) копии сообщения
    theme = .Range("C4").Value ' выбор темы сообщения
    Disclaimer = .Range("C5").Value ' выбор текста сообщения
End With

Set OutApp = CreateObject("Outlook.Application") ' создание нового экземпляра (объекта) приложения Microsoft Outlook для управления им из другого приложения (Excel или Word)
Set OutMail = OutApp.CreateItem(0) ' создание нового пустого элемента (письма) в приложении Microsoft Outlook
On Error Resume Next ' обработка игнорирование ошибок

Dim YourHTMLBody As String, iStart As Long, iEnd As Long ' вставка подписи в элемент (письмо)

YourHTMLBody = RangetoHTML(sh.Range(TABLE_RANGE))

With OutMail ' свойства элемента (письма)
    .To = adressTo ' получатель сообщения
    .CC = adressCC ' получатели копии сообщения
    .BCC = "" ' отправка элемента (письма) только основным получателям
    .Subject = theme
    .BodyFormat = 2 ' формат создаваемого элемента (письма) установить HTML
    
    .HTMLBody = YourHTMLBody
    
    .Display 

End With

If rng.Rows.Count > 1 Then
    Set rng = rng.Cells(2, 2).Resize(rng.Rows.Count - 1, rng.Columns.Count - 1)
    With Sheets("Реестр")
        rng.Copy .Cells(.Rows.Count, 2).End(xlUp).Cells(2, 1)
    End With
End If

Set OutMail = Nothing
Set OutApp = Nothing
sh.AutoFilterMode = False
ThisWorkbook.Save

With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

End Sub

Function RangetoHTML(rng As Range) As String
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
 
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
  
    ' Copy the range and create a workbook to receive the data.
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
  
    ' Publish the sheet to an .htm file.
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
  
    ' Read all data from the .htm file into the RangetoHTML subroutine.
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
  
    ' Close TempWB.
    TempWB.Close savechanges:=False
  
    ' Delete the htm file.
    Kill TempFile
  
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

=($U$22-B22)/100+B23

=РАНГ(B24;$B$24:$U$24;0)

=ЕСЛИ(ЕПУСТО(H$2);СУММЕСЛИМН($D:$D;$C:$C;$G:$G;$E:$E;">="&ДАТАЗНАЧ("15 " &G$2);$E:$E;"<="&КОНМЕСЯЦА(ДАТАЗНАЧ("1 " &G$2);0));СУММЕСЛИМН($D:$D;$C:$C;$G:$G;$E:$E;"<"&ДАТАЗНАЧ("15 " &H$2);$E:$E;">="&ДАТАЗНАЧ("1 " &H$2)))

=ЕСЛИ(ЕПУСТО(H$2);СУММЕСЛИМН($D:$D;$C:$C;$G:$G;$E:$E;">="&ДАТАЗНАЧ("15 " &G$2));СУММЕСЛИМН($D:$D;$C:$C;$G:$G;$E:$E;"<"&ДАТАЗНАЧ("15 " &H$2)))

=ЕСЛИ(ЕНД(ПОИСКПОЗ(СТРОКА(G1);$F$2:$F$4;0));"";B2)

=СЧЁТЕСЛИМН(B1:D2;"<0")

=ИНДЕКС(C:C;ПОИСКПОЗ(СЖПРОБЕЛЫ(ЛЕВСИМВ(ПОДСТАВИТЬ(P2;"-";ПОВТОР(" ";100));100));E:E;0))
=ИНДЕКС(C:C;ПОИСКПОЗ(СЖПРОБЕЛЫ(ПРАВСИМВ(ПОДСТАВИТЬ(P2;"-";ПОВТОР(" ";100));100));E:E;0)-1)

=СМЕЩ($D$1;ПОИСКПОЗ(ТЕКСТ($G3;"ГГГГ-ММ-ДД");$A:$A;0)+СТОЛБЕЦ(A:A)-1;0;1)

=СУММ(СМЕЩ($D$1;ПОИСКПОЗ(ТЕКСТ(G3;"ГГГГ-ММ-ДД");$A:$A;0);0;4))

=СУММЕСЛИМН(График!$C$67:$C$86;График!$B$67:$B$86;График!$B:$B)>СУММЕСЛИМН(График!$C$5:$C$64;График!$B$5:$B$64;График!$B:$B)

=СУММЕСЛИМН(Хозяйства!E:E;Хозяйства!D:D;Хозяйства!D:D)>СУММЕСЛИМН(График!C:C;График!B:B;Хозяйства!D:D)

Option Explicit

Sub Сумма_заказов()
    Sheet_job 2, "+", "", ""
End Sub

Sub Среднее_заказов()
    Sheet_job 3, ",", "AVERAGE(", ")"
End Sub

Private Sub Sheet_job(xPrint As Long, prefix1 As String, prefix2 As String, postfix3 As String)
    Dim cd As Range, vv As Variant, dic As Object, arr As Variant, ya As Long, ss As Variant
    Set dic = CreateObject("Scripting.Dictionary")
    arr = ActiveSheet.UsedRange.Columns("A:A").Value
    For ya = 1 To UBound(arr, 1)
        If Not IsEmpty(arr(ya, 1)) Then
            dic(arr(ya, 1)) = dic(arr(ya, 1)) & prefix1 & "B" & ya
        End If
    Next
    
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual

    For Each cd In ActiveSheet.UsedRange.Columns("D:D").Cells
        If Not IsEmpty(cd.Value) Then
            ss = ""
            For Each vv In Split(cd.Value, ";")
                If dic.Exists(Trim(vv)) Then
                    ss = ss & dic(Trim(vv))
                End If
            Next
            If ss = "" Then
                ss = Empty
            Else
                ss = Mid(ss, 2, Len(ss) - 1)
                ss = prefix2 & ss & postfix3
                ss = "=" & ss
            End If
            cd.Cells(1, xPrint).Formula = ss
        End If
    Next
    Application.Calculation = Application_Calculation
End Sub

=(СУММЕСЛИМН(B:B;A:A;СЖПРОБЕЛЫ(ПСТР(ПОДСТАВИТЬ(D1;";";ПОВТОР(" ";2*ДЛСТР(D1)));0*2*ДЛСТР(D1)+1;2*ДЛСТР(D1))))
+СУММЕСЛИМН(B:B;A:A;СЖПРОБЕЛЫ(ПСТР(ПОДСТАВИТЬ(D1;";";ПОВТОР(" ";2*ДЛСТР(D1)));1*2*ДЛСТР(D1)+1;2*ДЛСТР(D1))))
+СУММЕСЛИМН(B:B;A:A;СЖПРОБЕЛЫ(ПСТР(ПОДСТАВИТЬ(D1;";";ПОВТОР(" ";2*ДЛСТР(D1)));2*2*ДЛСТР(D1)+1;2*ДЛСТР(D1)))))
/((ДЛСТР(D1)-ДЛСТР(ПОДСТАВИТЬ(D1;"; ";"")))/ДЛСТР("; ")+1)

=СУММ(M1:XFD1)/СЧЁТЕСЛИМН(M1:XFD1;">0")

Option Explicit

Sub Сумм_заказов()
    Dim cd As Range, vv As Variant, dic As Object, arr As Variant, ya As Long, ss As Variant
    Set dic = CreateObject("Scripting.Dictionary")
    arr = ActiveSheet.UsedRange.Columns("A:A").Value
    For ya = 1 To UBound(arr, 1)
        If Not IsEmpty(arr(ya, 1)) Then
            dic(arr(ya, 1)) = dic(arr(ya, 1)) & "+B" & ya
        End If
    Next
    
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual

    For Each cd In ActiveSheet.UsedRange.Columns("D:D").Cells
        If Not IsEmpty(cd.Value) Then
            ss = ""
            For Each vv In Split(cd.Value, ";")
                If dic.Exists(Trim(vv)) Then
                    ss = ss & dic(Trim(vv))
                End If
            Next
            If ss = "" Then
                ss = Empty
            Else
                ss = Mid(ss, 2, Len(ss) - 1)
                ss = "=" & ss
            End If
            cd.Cells(1, 2).Formula = ss
        End If
    Next
    Application.Calculation = Application_Calculation
End Sub

=СУММЕСЛИМН(B:B;A:A;СЖПРОБЕЛЫ(ПСТР(ПОДСТАВИТЬ(D1;";";ПОВТОР(" ";2*ДЛСТР(D1)));0*2*ДЛСТР(D1)+1;2*ДЛСТР(D1))))
+СУММЕСЛИМН(B:B;A:A;СЖПРОБЕЛЫ(ПСТР(ПОДСТАВИТЬ(D1;";";ПОВТОР(" ";2*ДЛСТР(D1)));1*2*ДЛСТР(D1)+1;2*ДЛСТР(D1))))
+СУММЕСЛИМН(B:B;A:A;СЖПРОБЕЛЫ(ПСТР(ПОДСТАВИТЬ(D1;";";ПОВТОР(" ";2*ДЛСТР(D1)));2*2*ДЛСТР(D1)+1;2*ДЛСТР(D1))))