Sub main()
    Dim objDic As Object
    Dim xPath$, xArr(), lRow&, i&, xKey
    Dim xVal$, FSO As Object
    Dim xFile As Object, objFSO As Object
    
    
    xPath = ThisWorkbook.Path
    Set objDic = CreateObject("scripting.dictionary")
    Set FSO = CreateObject("scripting.filesystemobject")
    lRow = sht.Range("a" & sht.Rows.Count).End(xlUp).Row
    
    xArr = sht.Range("a2:d" & lRow).Value

    
    Set objFSO = FSO.GetFolder(xPath)
    For Each xFile In objFSO.Files
        xVal = xFile.ShortName
        objDic.Item(xVal) = 0
    Next xFile

    For i = 1 To UBound(xArr)
        xArr(i, 4) = ""
        For Each xKey In objDic.Keys
            If InStr(1, xKey, xArr(i, 1), vbTextCompare) > 0 Then xArr(i, 4) = 1: Exit For
         Next xKey
    Next i
    sht.[a2].Resize(UBound(xArr), 4).Value = xArr
End Sub

Option Explicit

Sub main()
    Dim arr(), i&
    arr = Range("a1:b" & Cells(Rows.Count, "a").End(xlUp).Row).Value
    For i = 1 To UBound(arr)
        arr(i, 2) = Val(ikg(arr(i, 1)))
    Next i
    arr = MergeSortMultiDimens(arr, 2)
    [b1].Resize(UBound(arr), 1).Value = arr
End Sub
'======================================================
Private Function ikg(ByVal cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "\d+(?= кг)"
   If .test(cell) Then
     ikg = .Execute(cell)(0)
     ikg = Format(ikg, "000")
   Else
     ikg = ""
   End If
 End With
End Function
'=====================================================
Private Function MergeSortMultiDimens(arr, cl&)
'   ----------------------------
    Dim arr_b(), arr_c(), rw&
    Dim m&, n&, k&, l&, i&, j&, st&, fn&
'   ----------------------------
    st = LBound(arr, 2): fn = UBound(arr, 2)
    m = UBound(arr)
    If m > 1 Then
        n = m \ 2
        ReDim arr_b(1 To n, st To fn)
        For i = 1 To n
            For rw = st To fn
                arr_b(i, rw) = arr(i, rw)
        Next rw, i
        arr_b = MergeSortMultiDimens(arr_b, cl)
        k = m - n
        ReDim arr_c(1 To k, st To fn)
        For i = 1 To k
            For rw = st To fn
                arr_c(i, rw) = arr(n + i, rw)
        Next rw, i
        arr_c = MergeSortMultiDimens(arr_c, cl)
        i = 1: j = 1: l = 1
        Do While i <= n And j <= k
            If arr_b(i, cl) < arr_c(j, cl) Then
                For rw = st To fn
                    arr(l, rw) = arr_b(i, rw)
                Next rw
                i = i + 1
            Else
                For rw = st To fn
                    arr(l, rw) = arr_c(j, rw)
                Next rw
                j = j + 1
            End If
            l = l + 1
        Loop
        Do While i <= n
            For rw = st To fn
                arr(l, rw) = arr_b(i, rw)
            Next rw
            i = i + 1
            l = l + 1
        Loop
        Do While j <= k
            For rw = st To fn
                arr(l, rw) = arr_c(j, rw)
            Next rw
            j = j + 1
            l = l + 1
        Loop
    End If
    MergeSortMultiDimens = arr
End Function