Sub Muka()
Dim i As Long
Dim j As Integer
Dim n As Integer
Dim FoundCell As Range
Dim FoundTown As Range
Dim FAdr As String
Dim arrTown
Dim ikg As Double
Dim iStr As String
   Range("B13:D14").ClearContents
For j = 2 To 4
  arrTown = Split(Split(Cells(12, j), "=")(1), "+")
     n = 0
   For n = 0 To UBound(arrTown)
    Set FoundTown = Rows(1).Find(arrTown(n), , xlValues, xlWhole)
      Cells(13, j) = Cells(13, j) + Cells(3, FoundTown.Column)
    Set FoundCell = Columns(1).Find("высшего", , xlValues, xlPart)
     If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
      Do
        With CreateObject("VBScript.RegExp")
            .Global = True
            .IgnoreCase = True
            .Pattern = "\d+(?= кг)"
            ikg = .Execute(FoundCell)(0)
        End With
          iStr = " 2 , 5 , 10 , 25 "
          'If ikg = 2 Or ikg = 5 Or ikg = 10 Or ikg = 25 Then
          If InStr(1, iStr, " " & ikg & " ") Then
            Cells(14, j) = Cells(14, j) + Cells(FoundCell.Row, FoundTown.Column)
          End If
            Set FoundCell = Columns(1).FindNext(FoundCell)
      Loop While FoundCell.Address <> FAdr
     End If
   Next
  Next
End Sub