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, ограниченной пустыми строками и столбцами
rng.Cells(1, rng.Columns.Count).Value = Replace(rng.Cells(1, rng.Columns.Count).Value, "передал", "педерал")
 
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, ограниченной пустыми строками и столбцами
rng.Cells(1, rng.Columns.Count).Value = Replace(rng.Cells(1, rng.Columns.Count).Value, "передал", "педерал")

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))))

=ИНДЕКС(Лист2!A2:A6;ПОИСКПОЗ(A3;Лист2!A1:A5;0))

If iStart > 0 And iEnd > 0 Then
        .HTMLBody = Left(.HTMLBody, iStart - 1) & YourHTMLBody & Mid(.HTMLBody, iEnd)
else
        .HTMLBody =YourHTMLBody 
End If

=(ПРАВСИМВ(ЯЧЕЙКА("формат";B2);2)<>",1")*(ЯЧЕЙКА("формат";B2)<>"P0")*ЕЧИСЛО(B2)

Option Explicit
'v2
Sub Find_in_file()
    Find_in_workbook ActiveWorkbook
End Sub

Sub Find_in_workbook(wb As Workbook)
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        Find_in_sheet sh
    Next
End Sub

Sub Find_in_sheet(sh As Worksheet)
    Dim ur As Range
    On Error Resume Next
    Set ur = sh.UsedRange
    On Error GoTo 0
    If ur Is Nothing Then Exit Sub
    
    Find_in_range ur
End Sub

Sub Find_in_range(rr As Range)
    Dim cl As Range
    For Each cl In rr.Cells
        Find_in_cell cl
    Next
End Sub

Sub Find_in_cell(cl As Range)
    If IsError(cl.Value) Then Exit Sub
    If IsEmpty(cl.Value) Then Exit Sub
    If Not IsNumeric(cl.Value) Then Exit Sub
    Select Case cl.NumberFormat
    Case "#,##0.0,,", "0%"
    Case Else
        cl.Interior.Color = RGB(255, 200, 200)
    End Select
End Sub

Option Explicit

Sub Find_in_file()
    Find_in_workbook ActiveWorkbook
End Sub

Sub Find_in_workbook(wb As Workbook)
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        Find_in_sheet sh
    Next
End Sub

Sub Find_in_sheet(sh As Worksheet)
    Dim ur As Range
    On Error Resume Next
    Set ur = sh.UsedRange
    On Error GoTo 0
    If ur Is Nothing Then Exit Sub
    
    Find_in_range ur
End Sub

Sub Find_in_range(rr As Range)
    Dim cl As Range
    For Each cl In rr.Cells
        Find_in_cell cl
    Next
End Sub

Sub Find_in_cell(cl As Range)
    If IsError(cl.Value) Then Exit Sub
    If IsEmpty(cl.Value) Then Exit Sub
    If Not IsNumeric(cl.Value) Then Exit Sub
    If cl.NumberFormat <> "#,##0.0,," Then
        cl.Interior.Color = RGB(255, 200, 200)
    End If
End Sub

Option Explicit

Sub Move_colors()
    Move_lines_job ActiveSheet
End Sub

Private Sub Move_lines_job(shSource As Worksheet)
    CloseEmptyWb
    shSource.Copy
    
    Dim FIO As Range
    Set FIO = ActiveSheet.UsedRange.Find("Ф.И.О.").Cells(1, 1)
    
    Dim dic As Object
    Set dic = GetDicColor(FIO)
    
    Dim vColor As Variant
    For Each vColor In dic.Keys()
        Move_one CStr(vColor), dic(vColor), FIO
    Next
End Sub

Private Sub Move_one(sheetName As String, sampleAddress As String, FIO As Range)
    FIO.Parent.Copy After:=FIO.Parent
    ActiveSheet.Name = sheetName
    
    Dim yu As Long, xu As Long, keepRow As Boolean
    Dim curColor As Long
    curColor = Range(sampleAddress).Interior.Color
    
    For yu = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1 To FIO.Row + 2 Step -1
        keepRow = False
        For xu = ActiveSheet.UsedRange.Column To ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
            If ActiveSheet.Cells(yu, xu).Interior.Color = curColor Then
                keepRow = True
                Exit For
            End If
        Next
        If keepRow Then
            For xu = FIO.Column To ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
                Select Case ActiveSheet.Cells(yu, xu).Interior.Color
                Case RGB(255, 255, 255), curColor
                Case Else
                    With ActiveSheet.Cells(yu, xu)
                        .ClearContents
                        .Interior.Pattern = xlNone
                    End With
                End Select
            Next
        Else
            ActiveSheet.Rows(yu).EntireRow.Delete
        End If
    Next
    
    ActiveWorkbook.Saved = True
End Sub

Private Function GetDicColor(FIO As Range) As Object
    Dim sh As Worksheet
    Set sh = FIO.Parent
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim yu As Long, xu As Long
    For yu = sh.UsedRange.Row + sh.UsedRange.Rows.Count - 1 To FIO.Row + 2 Step -1
        For xu = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1 To FIO.Column + 1 Step -1
            If sh.Cells(yu, xu).Interior.Color <> RGB(255, 255, 255) Then
                dic(sh.Cells(yu, xu).Interior.Color) = sh.Cells(yu, xu).Address(0, 0, xlA1)
            End If
        Next
    Next
    Set GetDicColor = dic
End Function

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 Move_lines()
    Move_lines_job ActiveSheet
End Sub
Private Sub Move_lines_job(shSource As Worksheet)
    CloseEmptyWb
    shSource.Copy
    
    Dim FIO As Range
    Set FIO = ActiveSheet.UsedRange.Find("Ф.И.О.").Cells(1, 1)
    
    Dim yu As Long, xu As Long, keepRow As Boolean
    Dim curColor As Long
    curColor = ActiveCell.Interior.Color
    
    For yu = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1 To FIO.Row + 2 Step -1
        keepRow = False
        For xu = ActiveSheet.UsedRange.Column To ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
            If ActiveSheet.Cells(yu, xu).Interior.Color = curColor Then
                keepRow = True
                Exit For
            End If
        Next
        If keepRow Then
            For xu = FIO.Column To ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
                Select Case ActiveSheet.Cells(yu, xu).Interior.Color
                Case RGB(255, 255, 255), curColor
                Case Else
                    With ActiveSheet.Cells(yu, xu)
                        .ClearContents
                        .Interior.Pattern = xlNone
                    End With
                End Select
            Next
        Else
            ActiveSheet.Rows(yu).EntireRow.Delete
        End If
    Next
    
    ActiveWorkbook.Saved = True
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

=SumByColor(C4:AG4;K4)