result = Table.AddColumn(
       names,
       "НАЗНАЧЕНИЕ",
       (x) => try Table.Skip(
           replacements,
           (w) => not Text.Contains(
               x[Назначение],
               w[old], Comparer.OrdinalIgnoreCase
           )
       ){0}[new] otherwise x[Назначение])      
      

let
    Источник = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content],
    #"Измененный тип" = Table.TransformColumnTypes(Источник,{{"Номер", type text}, {"Цена ед. изм.", type number}, {"Кол-во", Int64.Type}}),
    #"Сгруппированные строки" = Table.Group(#"Измененный тип", {"Наименование", "Цена ед. изм."}, 
    {{"Количество", each List.Sum([#"Кол-во"]), type nullable number}, {"проб", each Text.Combine(List.Distinct([Номер]),", ")}}),
    #"Переупорядоченные столбцы" = Table.ReorderColumns(#"Сгруппированные строки",{"проб", "Наименование", "Цена ед. изм.", "Количество"})
in
    #"Переупорядоченные столбцы"

Sub test()
    Dim rng As Object, r
    Set rng = CreateObject("Scripting.Dictionary")
    Dim arr As Variant
    Dim t As Long, a As Long, b As Long, c As Long, up_d As Long, k As Long
    
    nRows = Range("A" & Rows.Count).End(xlUp).Row
    arr = Range("A2:B" & nRows)

    For j = 1 To nRows - 1
        a = arr(j, 1)
        b = arr(j, 2)
        d = b - a
        t = 10 ^ (Len(d + 1) - 1) ' делитель для  диапазона с %
        up_d = Int(b / t)  'верхняя граница короткого сокращенного числа(с %).
        c = a
        k = IIf(a Mod t, 10, t)
        If d > 0 Then '  числа разные
            Do                
                Do
                    If c Mod k = 0 And d > 8 Then c = c / k
                    rng.Item(c & IIf(c < a, "%", "")) = 0
                    c = c + 1
                Loop Until c >= IIf(d < 10, b + 1, up_d)
            
                d = b - c * t
                t = 10 ^ (Len(d + 1) - 1)
                up_d = Int(b / t)
                c = 10 * Int(up_d / 10)
                k = c - 1
                
            Loop Until d <= 0
        End If
        If d = 0 Then '
            rng.Item(c) = 0
        End If
        
    Next
'   Range("D2").Resize(rng.Count, 1) = Application.Transpose(rng.Keys()) '  ограничение по количеству для транспонирования.
    k = rng.Count
    ReDim arr(0 To k, 1 To 1)
    c = 0
    For Each r In rng.Keys
        arr(c, 1) = r
        c = c + 1
    Next
    Range("D2").Resize(k, 1) = arr

End Sub

Sub remove_dubl_first()
Dim a As Long, b As Long
a = Cells(Rows.Count, 1).End(xlUp).Row
For b = a To 1 Step -1
If WorksheetFunction.CountIf(Range("A" & a & ":A" & b), Cells(b, 1)) > 1 Then Rows(b).Delete
Next
End Sub