=СУММЕСЛИМН(Январь!C:C;Январь!B:B;B:B)+СУММЕСЛИМН(Февраль!D:D;Февраль!C:C;B:B)+СУММЕСЛИМН(Март!H:H;Март!G:G;B:B)+СУММЕСЛИМН(Апрель!E:E;Апрель!D:D;B:B)+СУММЕСЛИМН(Май!E:E;Май!D:D;B:B)+СУММЕСЛИМН(Июнь!E:E;Июнь!D:D;B:B)

=СУММЕСЛИМН(Январь!B:B;Январь!A:A;$B:$B)+СУММЕСЛИМН(Февраль!B:B;Февраль!A:A;$B:$B)+СУММЕСЛИМН(Март!B:B;Март!A:A;$B:$B)+СУММЕСЛИМН(Апрель!B:B;Апрель!A:A;$B:$B)+СУММЕСЛИМН(Май!B:B;Май!A:A;$B:$B)+СУММЕСЛИМН(Июнь!B:B;Июнь!A:A;$B:$B)

=СУММ(D4:J4)

Sub Сумма_листов()
    Dim cs As Range
    For Each cs In Intersect(Sheets("Свод").UsedRange, Sheets("Свод").Columns("B:B")).Cells
        If Not IsEmpty(cs.Value) Then
            SumCell cs
        End If
    Next
End Sub

Private Sub SumCell(cs As Range)
    Dim sh As Worksheet, arr As Variant, cf As Range, ya As Long
    ReDim arr(1 To cs.Parent.Parent.Sheets.Count)
    For Each sh In cs.Parent.Parent.Sheets
        If sh.Index <> cs.Parent.Index Then
            Set cf = sh.Cells.Find(cs.Value)
            If Not cf Is Nothing Then
                ya = ya + 1
                arr(ya) = "'" & sh.Name & "'!" & cf.Cells(1, 2).Address(0, 0, xlA1)
                
                Set cf = Nothing
            End If
        End If
    Next
    If ya > 0 Then
        ReDim Preserve arr(1 To ya)
        cs.Cells(1, 2).Formula = "=" & Join(arr, "+")
    Else
        cs.Cells(1, 2).Value = Empty
    End If
End Sub

Sub myUnion()
    CloseEmptyWb
    ActiveSheet.Copy
    Dim sh As Worksheet
    Set sh = ActiveSheet
    
    Dim arr As Variant
    arr = sh.UsedRange
    
    Dim dicFio As Object
    Set dicFio = GetFioDic(arr)
    arr = GetOutputArray(dicFio, arr)
    PrintArray arr, sh
End Sub

Private Function GetFioDic(arr As Variant) As Object
    Dim dic As Object, fioDic As Object
    Set fioDic = CreateObject("Scripting.Dictionary")
    Dim ya As Long
    For ya = 2 To UBound(arr, 1)
        If Not IsEmpty(arr(ya, 4)) Then
            If fioDic.Exists(arr(ya, 4)) Then
                Set dic = fioDic(arr(ya, 4))
            Else
                Set dic = CreateObject("Scripting.Dictionary")
            End If
            dic(ya) = Empty
            Set fioDic(arr(ya, 4)) = dic
        End If
    Next
    Set GetFioDic = fioDic
End Function
    
Private Function GetOutputArray(dicFio As Object, arr As Variant) As Variant
    Dim yc As Long, yb As Long, vy As Variant, crr As Variant, fio As Variant, xa As Long, flag As Boolean, dic As Object
    ReDim crr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    yc = 1
    For xa = 1 To UBound(arr, 2)
        crr(yc, xa) = arr(1, xa)
    Next
    For Each fio In dicFio
        yc = yc + 1
        Set dic = dicFio(fio)
        ReDim brr(0 To dic.Count - 1)
        For xa = 1 To UBound(arr, 2)
            If xa >= 4 And xa <= 8 Then
                vy = dic.Keys()(0)
                crr(yc, xa) = arr(vy, xa)
            Else
                flag = False
                yb = LBound(brr) - 1
                For Each vy In dic
                    yb = yb + 1
                    brr(yb) = arr(vy, xa)
                    If Not IsEmpty(arr(vy, xa)) Then flag = True
                Next
                If flag Then crr(yc, xa) = Join(brr, ";")
            End If
        Next
    Next
    GetOutputArray = crr
End Function
    
Private Sub PrintArray(arr As Variant, sh As Worksheet)
    sh.Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
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

=ЕСЛИ(СМЕЩ('Данные в столбце'!$C$2;СТОЛБЕЦ()-1;0)=0;"";СМЕЩ('Данные в столбце'!$C$2;СТОЛБЕЦ()-1;0))

=ЕСЛИ(СМЕЩ('Данные в столбце'!$C$2;СТОЛБЕЦ()-1;0)=0;"";СМЕЩ('Данные в столбце'!$B$2;СТОЛБЕЦ()-1;0)-СМЕЩ('Данные в столбце'!$A$2;СТОЛБЕЦ()-1;0))

=СМЕЩ('Данные в столбце'!$C$2;СТОЛБЕЦ()-1;0)

=СМЕЩ('Данные в столбце'!$B$2;СТОЛБЕЦ()-1;0)-СМЕЩ('Данные в столбце'!$A$2;СТОЛБЕЦ()-1;0)

=ЕСЛИ(ЕПУСТО(B5);"";"-"&ЕСЛИОШИБКА(ВПР(B5;$B$11:$C$14;2;0);B5))&C6

=ПСТР(B6;2;ДЛСТР(B6))

=ОКРУГЛ(A1/1000;1)

Option Explicit
Private Const MIN_COLUMN_COUNT = 4

Sub Наибольшее_наименьшее()
    CloseEmptyWb
    JobRange sourceRange:=Range("B2:D16"), targetRange:=Workbooks.Add(1).Sheets(1).Range("B2")
End Sub

Private Sub JobRange(sourceRange As Range, targetRange As Range)
    Application.ScreenUpdating = False
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    Set targetRange = targetRange.Resize(sourceRange.Rows.Count, sourceRange.Columns.Count)
    sourceRange.Copy targetRange
    
    Dim srr As Variant, MinMax As Variant
    srr = sourceRange.Value
    
    Do
        For Each MinMax In Array("max", "min")
            If UBound(srr, 1) - CountEmptyRows(srr) = MIN_COLUMN_COUNT Then Exit Do
            If CountEmptyRows(srr) = UBound(srr, 1) Then Exit Do
            srr = ExceptMinMax(srr, MinMax)
            
            Set targetRange = targetRange.Offset(0, targetRange.Columns.Count + 2)
            sourceRange.Copy targetRange
            targetRange.Value = srr
        Next
        DoEvents
    Loop
    
    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
End Sub

Private Function ExceptMinMax(ByVal srr As Variant, ByVal oper As String) As Variant
    Dim ys As Long, xs As Long, maxVal As Long, maxRow As Long
    Dim yrr As Variant
    ReDim yrr(1 To UBound(srr, 1)) As Long
    
    If oper = "max" Then
        oper = "<"
    Else
        oper = ">"
    End If
    Do
        If CountEmptyRows(srr) = UBound(srr, 1) Then Exit Do
        If UBound(srr, 1) - CountEmptyRows(srr) <= MIN_COLUMN_COUNT Then Exit Do

        For xs = 1 To UBound(srr, 2)
            If myCountIf(yrr) >= UBound(srr, 2) Then Exit Do
            For maxRow = 1 To UBound(srr, 1)
                If Not IsEmpty(srr(maxRow, xs)) Then Exit For
            Next
            If maxRow <= UBound(srr, 1) Then
                maxVal = srr(maxRow, xs)
                For ys = maxRow + 1 To UBound(srr, 1)
                    If Compare(maxVal, oper, srr(ys, xs)) Then
                       maxVal = srr(ys, xs)
                       maxRow = ys
                    End If
                Next
                yrr(maxRow) = yrr(maxRow) + 1
            End If
        Next
        
        For ys = 1 To UBound(srr, 1)
            If yrr(ys) > 0 Then
                If UBound(srr, 1) - CountEmptyRows(srr) <= MIN_COLUMN_COUNT Then Exit Do
                For xs = 1 To UBound(srr, 2)
                    srr(ys, xs) = Empty
                Next
            End If
        Next
        DoEvents
    Loop
    ExceptMinMax = srr
End Function

Private Function Compare(maxVal As Long, oper As String, curVal As Variant) As Boolean
    If Not IsEmpty(curVal) Then
        If oper = "<" Then
            Compare = maxVal < curVal
        Else
            Compare = maxVal > curVal
        End If
    End If
End Function

Private Function CountEmptyRows(srr As Variant) As Long
    Dim ys As Long, xs As Long, flagEmpty As Boolean
    For ys = 1 To UBound(srr, 1)
        For xs = 1 To UBound(srr, 2)
            If Not IsEmpty(srr(ys, xs)) Then GoTo nextRow
        Next
        CountEmptyRows = CountEmptyRows + 1
nextRow:
    Next
End Function

Private Function myCountIf(yrr As Variant) As Long
    Dim yy As Long
    For yy = LBound(yrr) To UBound(yrr)
        If yrr(yy) > 0 Then
            myCountIf = myCountIf + 1
        End If
    Next
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

'v2
Sub mySort()
    SortRangeKeepFormulas Range("B2:E7"), Range("G2"), 4, xlDescending, 3, xlDescending, 2, xlAscending, 1, xlAscending
End Sub

Private Sub SortRangeKeepFormulas(rSource As Range, rTarget As Range, ParamArray arr() As Variant)
    Set rTarget = rTarget.Resize(rSource.Rows.Count, rSource.Columns.Count)
    
    rTarget.Value = rSource.Value

    Dim ys As Long
    For ys = 1 To rSource.Rows.Count
        rTarget.Cells(ys, 1).Value = ys
    Next
    
    SortRange rTarget, arr
    
    Dim yt As Long
    For yt = 1 To rTarget.Rows.Count
        ys = rTarget.Cells(yt, 1).Value
'        rSource.Rows(ys).Select
'        rTarget.Rows(yt).Select
        rSource.Rows(ys).Copy rTarget.Rows(yt)
        rTarget.Rows(yt).Formula = rSource.Rows(ys).Formula
    Next
End Sub

Private Sub SortRange(rTarget As Range, ParamArray arr() As Variant)
    With rTarget.Parent.Sort
        .SortFields.Clear
        Dim xa As Long
        For xa = LBound(arr(0)) To UBound(arr(0)) Step 2
            .SortFields.Add Key:=rTarget.Columns(arr(0)(xa)), SortOn:=xlSortOnValues, Order:=arr(0)(xa + 1), DataOption:=xlSortNormal
        Next
        .SetRange rTarget
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Option Explicit

Sub mySort()
    SortRangeKeepFormulas Range("B2:E7"), Range("G2"), 4, xlDescending, 3, xlDescending, 2, xlAscending, 1, xlAscending
End Sub

Private Sub SortRangeKeepFormulas(rSource As Range, rTarget As Range, ParamArray arr() As Variant)
    Set rTarget = rTarget.Resize(rSource.Rows.Count, rSource.Columns.Count)
    
    rSource.Copy rTarget
    rTarget.Value = rSource.Value

    Dim ys As Long, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For ys = 1 To rSource.Rows.Count
        dic(rSource.Cells(ys, 1).Value & "#" & ys) = rSource.Rows(ys).Formula
        rTarget.Cells(ys, 1).Value = rSource.Cells(ys, 1).Value & "#" & ys
    Next
    
    SortRange rTarget, arr
    
    For ys = 1 To rTarget.Rows.Count
        rTarget.Rows(ys).Formula = dic(rTarget.Cells(ys, 1).Value)
    Next
End Sub

Private Sub SortRange(rTarget As Range, ParamArray arr() As Variant)
    With rTarget.Parent.Sort
        .SortFields.Clear
        Dim xa As Long
        For xa = LBound(arr(0)) To UBound(arr(0)) Step 2
            .SortFields.Add Key:=rTarget.Columns(arr(0)(xa)), SortOn:=xlSortOnValues, Order:=arr(0)(xa + 1), DataOption:=xlSortNormal
        Next
        .SetRange rTarget
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Option Explicit
Private targetSheet As Worksheet
Private sourceRange As Range
'v2
Sub Заполнить_шаблон()
    CloseEmptyWb
    Dim openedWorkbooks As Collection
    Set openedWorkbooks = GetOpenedWorkbooks()
    
    Set sourceRange = GetSourceRange()
    If sourceRange Is Nothing Then
        OpenByDialog ThisWorkbook.Sheets(1).Cells(1, 30), "Выберите файлы", True
        Set sourceRange = GetSourceRange()
    End If
    If sourceRange Is Nothing Then Exit Sub
    Set targetSheet = GetTargetSheet()
    If targetSheet Is Nothing Then
        OpenByDialog ThisWorkbook.Sheets(1).Cells(2, 30), "Выберите файл-шаблон", False
        Set targetSheet = GetTargetSheet()
    End If
    If targetSheet Is Nothing Then Exit Sub
    FillTargetSheet
    
    CloseWorkbooks openedWorkbooks
End Sub

Private Sub FillTargetSheet()
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    Dim sourceCell As Range, targetCell As Range, countRows As Long
    Set targetCell = targetSheet.Range("A15")
    For Each sourceCell In sourceRange.EntireRow.Columns(1).Cells
        If Not IsEmpty(sourceCell.Value) And sourceCell.Row > 1 Then
            countRows = countRows + 1
            targetCell.Range("A1").Value = countRows
            targetCell.Range("B1").Value = sourceCell.Range("A1").Value
            targetCell.Range("C1").Value = sourceCell.Range("B1").Value
            targetCell.Range("G1").Value = sourceCell.Range("D1").Value
            targetCell.Range("J1").Value = sourceCell.Range("F1").Value
            targetCell.Range("K1").Value = sourceCell.Range("E1").Value
            
            Set targetCell = targetCell.Cells(2, 1)
        End If
    Next
    
    Application.Calculation = Application_Calculation
    targetSheet.Parent.Saved = True
End Sub

Private Function GetSourceRange() As Range
    If IsSourceSheet(ActiveSheet) Then
        If Intersect(Selection, ActiveSheet.UsedRange) Is Nothing Then
            Set GetSourceRange = ActiveSheet.UsedRange
            Exit Function
        Else
            Set GetSourceRange = Intersect(Selection, ActiveSheet.UsedRange)
            Exit Function
        End If
    End If
    
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Sheets
        If IsSourceSheet(sh) Then
            Set GetSourceRange = sh.UsedRange
            Exit Function
        End If
    Next
    
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        For Each sh In wb.Sheets
            If IsSourceSheet(sh) Then
                Set GetSourceRange = sh.UsedRange
                Exit Function
            End If
        Next
    Next
End Function

Private Function IsSourceSheet(sh As Worksheet) As Boolean
    If sh.Range("A1").Value = "Артикул" Then
        IsSourceSheet = True
    End If
End Function

Private Function IsTargetSheet(sh As Worksheet) As Boolean
    If sh.Range("B13").Value = "Артикул" Then
        IsTargetSheet = True
    End If
End Function

Private Function GetTargetSheet() As Worksheet
    If IsTargetSheet(ActiveSheet) Then
        Set GetTargetSheet = ActiveSheet
        GoTo foundTargetSheet
    End If
    
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Sheets
        If IsTargetSheet(sh) Then
            Set GetTargetSheet = sh
            GoTo foundTargetSheet
        End If
    Next
        
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        For Each sh In wb.Sheets
            If IsTargetSheet(sh) Then
                Set GetTargetSheet = sh
                GoTo foundTargetSheet
            End If
        Next
    Next
    Exit Function
foundTargetSheet:
    GetTargetSheet.Copy
    Set GetTargetSheet = ActiveSheet
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

Private Sub OpenByDialog(rInitialFileName As Range, sTitle As String, bAllowMultiSelect As Boolean)
    Dim aFiles As Variant
    aFiles = ShowFileDialog(rInitialFileName, sTitle, bAllowMultiSelect)
    If IsEmpty(aFiles) Then Exit Sub
    Dim vFile As Variant
    For Each vFile In aFiles
        Workbooks.Open vFile, False, True
    Next
End Sub

Private Function ShowFileDialog(rInitialFileName As Range, sTitle As String, bAllowMultiSelect As Boolean) As Variant
    Dim sInitialFileName As String
    sInitialFileName = rInitialFileName.Value
    If Left(sInitialFileName, 2) = ".\" Then
        sInitialFileName = Mid(sInitialFileName, 2)
        sInitialFileName = ActiveWorkbook.Path & sInitialFileName
    End If
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim oFD As FileDialog
    Dim lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = bAllowMultiSelect
        .Title = sTitle 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = sInitialFileName
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant, sName As String
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            sName = fso.GetFileName(.SelectedItems(lf))
            If Left(sName, 2) <> "~$" Then
                If sName <> ThisWorkbook.Name Then
                    If IsEmpty(arr) Then
                        ReDim arr(1 To 1)
                        If Not rInitialFileName Is Nothing Then
                            sInitialFileName = .SelectedItems(lf)
                            sInitialFileName = Replace(sInitialFileName, ActiveWorkbook.Path, ".")
                            rInitialFileName.Value = sInitialFileName
                        End If
                    Else
                        ReDim Preserve arr(1 To UBound(arr) + 1)
                    End If
                    arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
                End If
            End If
        Next
        ShowFileDialog = arr
    End With
End Function

Private Function GetOpenedWorkbooks() As Collection
    Set GetOpenedWorkbooks = New Collection
    
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        GetOpenedWorkbooks.Add wb
    Next
End Function

Private Sub CloseWorkbooks(openedWorkbooks As Collection)
    Dim wb As Workbook, openedWorkbook As Workbook
    For Each wb In Application.Workbooks
        If wb.Name = targetSheet.Parent.Name Then
             GoTo dontCloseWorkbook
        End If
        For Each openedWorkbook In openedWorkbooks
            If wb.Name = openedWorkbook.Name Then
                GoTo dontCloseWorkbook
            End If
        Next
        wb.Close False
dontCloseWorkbook:
    Next
    
    If ThisWorkbook.Name <> targetSheet.Parent.Name Then ThisWorkbook.Close True
End Sub

=ЦЕЛОЕ(A2+B2+D2/C2/24)    'Дата окночания
=ОСТАТ(A2+B2+D2/C2/24;1)  'Время окончания

Option Explicit
Private targetSheet As Worksheet
Private sourceRange As Range

Sub Заполнить_шаблон()
    CloseEmptyWb
    Set sourceRange = GetSourceRange()
    If sourceRange Is Nothing Then Exit Sub
    Set targetSheet = GetTargetSheet()
    If targetSheet Is Nothing Then Exit Sub
    FillTargetSheet
End Sub

Private Sub FillTargetSheet()
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    Dim sourceCell As Range, targetCell As Range, countRows As Long
    Set targetCell = targetSheet.Range("A15")
    For Each sourceCell In sourceRange.EntireRow.Columns(1).Cells
        If Not IsEmpty(sourceCell.Value) And sourceCell.Row > 1 Then
            countRows = countRows + 1
            targetCell.Range("A1").Value = countRows
            targetCell.Range("B1").Value = sourceCell.Range("A1").Value
            targetCell.Range("C1").Value = sourceCell.Range("B1").Value
            targetCell.Range("G1").Value = sourceCell.Range("D1").Value
            targetCell.Range("J1").Value = sourceCell.Range("F1").Value
            targetCell.Range("K1").Value = sourceCell.Range("E1").Value
            
            Set targetCell = targetCell.Cells(2, 1)
        End If
    Next
    
    Application.Calculation = Application_Calculation
    targetSheet.Parent.Saved = True
End Sub

Private Function GetSourceRange() As Range
    If IsSourceSheet(ActiveSheet) Then
        If Intersect(Selection, ActiveSheet.UsedRange) Is Nothing Then
            Set GetSourceRange = ActiveSheet.UsedRange
            Exit Function
        Else
            Set GetSourceRange = Intersect(Selection, ActiveSheet.UsedRange)
            Exit Function
        End If
    End If
    
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Sheets
        If IsSourceSheet(sh) Then
            Set GetSourceRange = sh.UsedRange
            Exit Function
        End If
    Next
    
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        For Each sh In wb.Sheets
            If IsSourceSheet(sh) Then
                Set GetSourceRange = sh.UsedRange
                Exit Function
            End If
        Next
    Next
End Function

Private Function IsSourceSheet(sh As Worksheet) As Boolean
    If sh.Range("A1").Value = "Артикул" Then
        IsSourceSheet = True
    End If
End Function

Private Function GetTargetSheet() As Worksheet
    Workbooks("Шаблон.xls").Sheets("Лист1").Copy
    Set GetTargetSheet = ActiveSheet
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

    Dim wb As Workbook
    For Each wb In Application.Workbooks
        On Error Resume Next
        wb.Worksheets("Оборудование").Rows("1:4").Copy wb.Worksheets("Результаты").Rows("1:1")
        If Err = 0 Then Exit For
        On Error GoTo 0
    Next

    Dim wb As Workbook, goodWorkbook As Boolean
    For Each wb In Application.Workbooks
        On Error Resume Next
        With wb.Worksheets("Оборудование"): End With
        With wb.Worksheets("Результаты"): End With
        goodWorkbook = (Err = 0)
        On Error GoTo 0
        If goodWorkbook Then
            wb.Worksheets("Оборудование").Rows("1:4").Copy wb.Worksheets("Результаты").Rows("1:1")
            Exit For
        End If
    Next

Sub HighlightMinValueInRows()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
 
    Dim searchText As String
    searchText = "ИТОГО с учетом индексации и курсов валют с НДС 22%"
 
    Dim r As Long
    Dim c As Long
    Dim minVal As Variant
    Dim minCell As Range
    Dim lastCol As Long
    Dim cellValue As Variant
    Dim numVal As Double
 
    Application.ScreenUpdating = False
 
    For r = 1 To lastRow
        ' Проверяем, соответствует ли ячейка в столбце C искомому тексту
        If ws.Cells(r, "C").Value = searchText Then
            ' Определяем последний заполненный столбец в текущей строке
            lastCol = ws.Cells(r, ws.Columns.Count).End(xlToLeft).Column
            minVal = Empty
            Set minCell = Nothing
            For c = 1 To lastCol
                cellValue = ws.Cells(r, c).Value
                ' Проверяем, что значение числовое
                If IsNumeric(cellValue) Then
                    ' Преобразуем в число для сравнения
                    numVal = CDbl(cellValue)
                    If IsEmpty(minVal) Or numVal < minVal Then
                        minVal = numVal
                        Set minCell = ws.Cells(r, c)
                    End If
                End If
            Next c
            ' Если минимальное число найдено — выделяем ячейку жёлтым
            If Not minCell Is Nothing Then
                minCell.Interior.Color = vbYellow
            End If
        End If
    Next r
 
    Application.ScreenUpdating = True
    MsgBox "Готово! Минимальные значения выделены жёлтым.", vbInformation
 
End Sub

=ЕСЛИОШИБКА(ИНДЕКС(Лист1!$H$1:$H$20362;ЕСЛИОШИБКА(ПОИСКПОЗ("*"&ЗНАЧЕН(C4)&"*";Лист1!F:F;0);ЕСЛИОШИБКА(ПОИСКПОЗ("*"&C4&"*";Лист1!F:F;0);20362+1)));"Нет совпадений")