Sub ddd()
Dim l, m As Long
Dim a, b, c
With ThisWorkbook.Sheets("BASE")
KilkRow = .Cells(Rows.Count, 1).End(xlUp).Row
a = Range(.[F2], .Range("H" & KilkRow)).Value
End With
With ThisWorkbook.Sheets("BASE0")
 'iLastrow2 = .Cells(Rows.Count, 1).End(xlUp).Row
b = Range(.Cells(2, part0), .Cells(KilkRow0, kilk0)).Value
End With
ReDim c(1 To UBound(a, 1), 1 To 1)
For l = 1 To UBound(a)
PartBase = a(l, 1)
KilkBase = a(l, 3)
For m = 1 To UBound(b)
ThisWorkbook.Worksheets("BASE0").Activate
kilpart = Application.WorksheetFunction.CountIf(Range(Cells(2, part0), Cells(KilkRow0, part0)), PartBase)
If (kilpart = 0) Then
c(l, 1) = "1"
Else  If (b(m, 1) = PartBase) And (b(m, 3) <> KilkBase) Then  c(l, 1) = "2"
Else
End If: End If
Next m
Next l
With ThisWorkbook.Sheets("BASE")
Range(.[W2], .Range("W" & KilkRow)).Value = c
End With
End Sub

On Error Resume Next
For Each nmName In ActiveWorkbook.Names
If Not nmName.Name Like ("*!Print_Area") Then
nmName.Delete
Else: End If
Next nmName