Sub Koniashka26()
Dim arr(), newArr()
Dim iKey, iTmp, arrTmp
Dim I&, J&, N&
On Error Resume Next
Application.ScreenUpdating = False
With Worksheets("Лист1")
  arr = .Range("A5:F" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
With CreateObject("Scripting.Dictionary")
  For I = LBound(arr, 1) To UBound(arr, 1)
    iKey = Trim(arr(I, 3))
    If .Exists(iKey) Then
      arrTmp = .Item(iKey)
      arrTmp(1, 2) = arrTmp(1, 2) & vbCrLf & arr(I, 2)
      arrTmp(1, 5) = arrTmp(1, 5) + arr(I, 5)
      .Item(iKey) = arrTmp
    Else
      ReDim arrTmp(1 To 1, LBound(arr, 2) To UBound(arr, 2))
      For J = LBound(arr, 2) To UBound(arr, 2)
        arrTmp(1, J) = arr(I, J)
      Next
      .Add iKey, arrTmp
    End If
  Next
  ReDim newArr(1 To .Count, LBound(arr, 2) To UBound(arr, 2))
  For Each iKey In .Keys
    arrTmp = .Item(iKey)
    For I = LBound(arrTmp, 1) To UBound(arrTmp, 1)
      N = N + 1
      For J = LBound(arrTmp, 2) To UBound(arrTmp, 2)
        newArr(N, J) = arrTmp(1, J)
      Next
    Next
  Next
End With
With Worksheets("Лист2")
  .Range("A1").Resize(N, UBound(newArr, 2)) = newArr
  .Columns("A:F").WrapText = False
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Sub Numbering()
Dim iCl As Range
Dim mCl As Range
Dim fNumber$
Application.ScreenUpdating = False
For Each iCl In Selection
  If iCl.MergeCells Then
    If Not IsEmpty(iCl) Then
      fNumber = Trim(CStr(iCl.Value))
      For Each mCl In iCl.MergeArea.Cells
        N = N + 1
        mCl.Offset(, 3) = fNumber & "." & N
      Next
    End If
  Else
    iCl.Offset(, 3) = Trim(CStr(iCl.Value)) & ".1"
  End If
  N = 0
Next
Application.ScreenUpdating = True
End Sub

Sub OPL_Count()
  Dim folderPath As String, fileName As String
  Dim iWb As Workbook
  Dim iSh As Worksheet
  Dim arr()
  Dim I&, oplCount&
  
  On Error Resume Next
  Application.ScreenUpdating = False
  ReDim arr(1 To 3, 1 To 1)
  ' Путь к папке
'  folderPath = "C:\Прайсы"
  folderPath = ThisWorkbook.Worksheets("Лист1").Range("E1") & Application.PathSeparator 'путь к апапке в ячейке 'E1'
  ' Получаем первый файл в папке
  fileName = Dir(folderPath & Application.PathSeparator & "*.xls*")

  ' Пока есть файлы в папке
  Do While fileName <> ""
    Set iWb = Application.Workbooks.Open(folderPath & fileName)
    If Not iWb Is Nothing Then
      For Each iSh In iWb.Worksheets
        oplCount = Application.WorksheetFunction.CountIf(iSh.UsedRange, "*" & ThisWorkbook.Worksheets("Лист1").Range("E2") & "*")
        If oplCount > 0 Then
          I = I + 1
          ReDim Preserve arr(1 To 3, 1 To I)
          arr(1, I) = iWb.Name
          arr(2, I) = iSh.Name
          arr(3, I) = oplCount
        End If
      Next
      iWb.Close False
    End If
    fileName = Dir()
  Loop
  With ThisWorkbook.Worksheets("Лист1")
    .Range("A1:C" & .Cells(.Rows.count, "A").End(xlUp).Row).ClearContents
    .Range("A1").Resize(I, 3) = Application.Transpose(arr)
    .Columns("A:C").EntireColumn.AutoFit
  End With
  Application.ScreenUpdating = True
  ' Выводим сообщение об успешном завершении
  MsgBox "Список файлов сформирован."
End Sub

Sub RedNumber1()
Const iCond = 550 'значение для сравнения чисел из ячейки
Dim iCl As Range
Dim iTmp, iKey, N&
On Error Resume Next
Application.ScreenUpdating = False
For Each iCl In Selection 'обрабатываем выделенный диапазон
  iCl.Font.ColorIndex = xlAutomatic
  iCl = iCl.Text  'в этой строке формула меняется на значение и дальше уже обрабатывается
  iTmp = Split(iCl, ";")
  For Each iKey In iTmp
    iKey = Replace(Trim(iKey), " ", "")
    If iKey <> "" Then
      If CDbl(Trim(iKey)) > iCond Then
        N = InStr(1, iCl.Text, Trim(iKey), vbTextCompare)
        iCl.Characters(N, Len(Trim(iKey))).Font.Color = vbRed
      End If
    End If
  Next
Next
Application.ScreenUpdating = True
End Sub

Sub RedNumber()
Const iCond = 550 'значение для сравнения чисел из ячейки
Dim iCl As Range
Dim iTmp, iKey, N&
On Error Resume Next
Application.ScreenUpdating = False
For Each iCl In Selection 'обрабатываем выделенный диапазон
  iCl.Font.ColorIndex = xlAutomatic
  iTmp = Split(iCl, ";")
  For Each iKey In iTmp
    iKey = Replace(Trim(iKey), " ", "")
    If iKey <> "" Then
      If CDbl(Trim(iKey)) > iCond Then
        N = InStr(1, iCl.Text, Trim(iKey), vbTextCompare)
        iCl.Characters(N, Len(Trim(iKey))).Font.Color = vbRed
      End If
    End If
  Next
Next
Application.ScreenUpdating = True
End Sub

let
    Источник = Folder.Files(Excel.CurrentWorkbook(){[Name="FolderPath"]}[Content]{0}[Путь к папке]),
    #"Строки с примененным фильтром" = Table.SelectRows(Источник, each ([Name] = "нлк1.xlsx" or [Name] = "нлк2.xlsx")),
    #"Добавлен пользовательский объект" = Table.AddColumn(#"Строки с примененным фильтром", "Сводные данные", each Excel.Workbook([Content])),
    #"Развернутый элемент Сводные данные" = Table.ExpandTableColumn(#"Добавлен пользовательский объект", "Сводные данные", {"Name", "Data", "Item", "Kind", "Hidden"}, {"Name.1", "Data", "Item", "Kind", "Hidden"}),
    #"Строки с примененным фильтром1" = Table.SelectRows(#"Развернутый элемент Сводные данные", each ([Name.1] = "Лист1")),
    #"Другие удаленные столбцы" = Table.SelectColumns(#"Строки с примененным фильтром1",{"Data"}),
    #"Развернутый элемент Data" = Table.ExpandTableColumn(#"Другие удаленные столбцы", "Data", {"Column1", "Column2", "Column3", "Column4", "Column5", "Column6", "Column7", "Column8", "Column9", "Column10", "Column11", "Column12"}, {"Column1", "Column2", "Column3", "Column4", "Column5", "Column6", "Column7", "Column8", "Column9", "Column10", "Column11", "Column12"}),
    #"Повышенные заголовки" = Table.PromoteHeaders(#"Развернутый элемент Data", [PromoteAllScalars=true]),
    #"Измененный тип" = Table.TransformColumnTypes(#"Повышенные заголовки",{{"дней", type any}, {"Юр лицо", type text}, {"Отдел", type text}, {"Код товара", type any}, {"Товар", type text}, {"Производитель", type text}, {"Вид товара", type text}, {"Потребительская категория", type any}, {"МНН", type any}, {"Остатки Кол-во", type any}, {"Остатки Сумма розн", type any}, {"Ваш заказ", type text}}),
    #"Строки с примененным фильтром2" = Table.SelectRows(#"Измененный тип", each ([дней] <> "дней")),
    #"Другие удаленные столбцы1" = Table.SelectColumns(#"Строки с примененным фильтром2",{"дней", "Код товара", "Товар"}),
    #"Измененный тип1" = Table.TransformColumnTypes(#"Другие удаленные столбцы1",{{"Код товара", type text}}),
    #"Добавлен пользовательский объект1" = Table.AddColumn(#"Измененный тип1", "КОДЫ ИТОГ", each "[КОД ТОВАРА] = "&[Код товара]&"ИЛИ")
in
    #"Добавлен пользовательский объект1"