=ЕСЛИ(ЕПУСТО(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)));"Нет совпадений")

=ЗНАЧЕН(СЖПРОБЕЛЫ(ПСТР(ПОДСТАВИТЬ($A3;"|";ПОВТОР(" ";100));ПОИСК(B$2&"-";ПОДСТАВИТЬ($A3;"|";ПОВТОР(" ";100)))+ДЛСТР(B$2)+1;100)))

Function ВЫТАЩИТЬ2(строка As String, символ1 As String, символ2 As String) As String
    Dim arr As Variant, brr As Variant, crr As Variant
    arr = Split(строка, символ1)
    ReDim brr(LBound(arr) To UBound(arr))
    
    Dim vv As Variant, yb As Long, xc As Long
    yb = LBound(brr) - 1
    For Each vv In arr
        crr = Split(vv, символ2)
        If UBound(crr) > LBound(crr) Then
            yb = yb + 1
            If InStr(crr(UBound(crr)), ".") = 0 Then
                xc = UBound(crr)
            Else
                xc = LBound(crr)
            End If
            brr(yb) = crr(xc)
        End If
    Next
    If yb >= LBound(brr) Then
        ReDim Preserve brr(LBound(brr) To yb)
        ВЫТАЩИТЬ2 = Join(brr, "+")
    End If
End Function

=ВЫТАЩИТЬ2(A1;"/";"-")
=ВЫТАЩИТЬ2(A1;"-";"/") 'будет работать, как предыдущий вариант.

Function ВЫТАЩИТЬ(строка As String, символ As String) As String
    Dim arr As Variant, brr As Variant, crr As Variant
    arr = Split(строка, "-")
    ReDim brr(LBound(arr) To UBound(arr))
    
    Dim vv As Variant, yb As Long
    yb = LBound(brr) - 1
    For Each vv In arr
        crr = Split(vv, символ)
        If UBound(crr) > LBound(crr) Then
            yb = yb + 1
            brr(yb) = crr(UBound(crr))
        End If
    Next
    If yb >= LBound(brr) Then
        ReDim Preserve brr(LBound(brr) To yb)
        ВЫТАЩИТЬ = Join(brr, "+")
    End If
End Function

=ВЫТАЩИТЬ(A1;"/")

=СЧЁТЕСЛИМН(B:B;СЖПРОБЕЛЫ(A1)&"*")>0

=СЧЁТЕСЛИМН(B:B;A2)>0

=СЧЁТЕСЛИМН(A:A;B2)>0

Sub Удалить_дубликаты()
    CloseEmptyWb

    Dim arr As Variant
    arr = GetPrintArray(Range("A2").CurrentRegion)
    
    PrintArray arr
End Sub

Private Sub PrintArray(arr As Variant)
    Workbooks.Add (1)
    Dim rr As Range
    Set rr = Cells(2, 1).Resize(UBound(arr, 1), UBound(arr, 2))
    rr.Value = arr
    rr.Columns(1).EntireColumn.AutoFit
    
    rr.Parent.Parent.Saved = True
End Sub

Private Function GetPrintArray(source As Range) As Variant
    Dim arr As Variant
    arr = Intersect(source, source.Parent.UsedRange).Columns("A:B").Value
    
    Dim dic As Object
    Set dic = GetDic(arr)
    
    Dim brr As Variant, yb As Long
    ReDim brr(1 To dic.Count, 1 To 2)
    For yb = 1 To UBound(brr, 1)
        brr(yb, 1) = dic.keys()(yb - 1)
        brr(yb, 2) = Join(dic.Items()(yb - 1).keys(), " ")
    Next
    GetPrintArray = brr
End Function

Private Function GetDic(arr As Variant) As Object

    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        If IsEmpty(arr(ya, 1)) Then
        ElseIf IsEmpty(arr(ya, 2)) Then
        Else
            If Not dic.Exists(arr(ya, 1)) Then
                Set dic(arr(ya, 1)) = CreateObject("Scripting.Dictionary")
            End If
            dic(arr(ya, 1))(arr(ya, 2)) = Empty
        End If
    Next
    
    Set GetDic = 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

=ЕСЛИОШИБКА(ИНДЕКС(Факт!$C$1:$C$99;100-НАИБОЛЬШИЙ((Таблица2[Заказчик]=Таблица6[@ЗАКАЗЧИК])*(100-СТРОКА(Таблица2[Заказчик]));СТОЛБЕЦ(A:A)));" ")

=СМЕЩ(D2;0;0;1;ПОИСКПОЗ(" ";D2:G2;0)-1)

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Const doc = "F26"
    Const prn = "E29:H30"
    Const VALUE_MODE = False
    
    If Intersect(Target, Range(doc)) Is Nothing Then Exit Sub
    
    Dim tb As ListObject
    Set tb = ActiveSheet.ListObjects(1)
    
    Dim aTarget As Variant
    With Range(prn)
        ReDim aTarget(1 To .Rows.Count, 1 To .Columns.Count)
    End With
    
    Dim aSource As Variant
    On Error Resume Next
    aSource = tb.ListColumns(Range(doc).Value).DataBodyRange.Value
    On Error GoTo 0
    If Not IsEmpty(aSource) Then
        Dim aNN As Variant
        aNN = tb.ListColumns("НН").DataBodyRange.Value
        Dim ySource As Long, xTarget As Long
        For ySource = 1 To UBound(aSource, 1)
            If Not IsEmpty(aSource(ySource, 1)) Then
                xTarget = xTarget + 1
                If xTarget > UBound(aTarget, 2) Then Exit For
                If VALUE_MODE Then
                    aTarget(1, xTarget) = aNN(ySource, 1)
                    aTarget(2, xTarget) = aSource(ySource, 1)
                Else
                    aTarget(1, xTarget) = "=" & tb.ListColumns("НН").DataBodyRange.Cells(ySource, 1).Address(0, 0, xlA1)
                    aTarget(2, xTarget) = "=" & tb.ListColumns(Range(doc).Value).DataBodyRange.Cells(ySource, 1).Address(0, 0, xlA1)
                End If
            End If
        Next
    End If
    Range(prn).Value = aTarget
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
   'проверка: если столбец не I - выход
   If Target.Column <> 9 Then Exit Sub
   'проверка: если строка меньше 2 - выход
   If Target.Row < 2 Then Exit Sub
   'проверка: если изменили более одной ячейки - выход
   If Target.Count > 1 Then Exit Sub
   'проверка: если в ячейку ничего не ввели(удаление) - выход
   If Len(Target) = 0 Then Exit Sub
      
   Dim s$, sFolder As String
   
   With CreateObject("Scripting.FileSystemObject").OpenTextFile("C:\tmp\1.txt", 1)
        Do
            If .AtEndOfStream Then Exit Do
            sFolder = .ReadLine
            'создаем путь к файлу
            s = sFolder & Target.Value & ".pdf"
            If Dir(s) <> "" Then
                'отключаем отслеживание событий, чтобы не было зацикливания при создании ссылки
                Application.EnableEvents = 0
                'создаем гиперссылку
                Me.Hyperlinks.Add Anchor:=Target, Address:=s, TextToDisplay:=CStr(Target.Value)
                'возвращаем отслеживание событий
                Application.EnableEvents = 1
                Exit Do
            End If
            DoEvents
        Loop
    End With
End Sub

*(ДЕНЬНЕД($R$2:$NR$2;2)<6)

Private Sub Worksheet_Change(ByVal Target As Range)
   'проверка: если столбец не I - выход
   If Target.Column <> 9 Then Exit Sub
   'проверка: если строка меньше 2 - выход
   If Target.Row < 2 Then Exit Sub
   'проверка: если изменили более одной ячейки - выход
   If Target.Count > 1 Then Exit Sub
   'проверка: если в ячейку ничего не ввели(удаление) - выход
   If Len(Target) = 0 Then Exit Sub
     
   Dim s$
   Dim vFolder As Variant
   For Each vFolder In Array("C:\tmp\", "C:\temp\")
        'создаем путь к файлу
        s = vFolder & Target.Value & ".pdf"
        If Dir(s) <> "" Then
            'отключаем отслеживание событий, чтобы не было зацикливания при создании ссылки
            Application.EnableEvents = 0
            'создаем гиперссылку
            Me.Hyperlinks.Add Anchor:=Target, Address:=s, TextToDisplay:=CStr(Target.Value)
            'возвращаем отслеживание событий
            Application.EnableEvents = 1
            Exit For
        End If
    Next
End Sub