Sub Подсчет()

    Dim arr(), res(), lngCounter As Long
    Dim var, lr As Long, i As Long, ii As Long
    
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    arr() = Range("A1:B" & lr).Value
    For i = 1 To UBound(arr)
        arr(i, 1) = "," & arr(i, 1) & ","
        arr(i, 1) = LCase(arr(i, 1))
        arr(i, 2) = LCase(arr(i, 2))
    Next i
    ReDim res(1 To UBound(arr), 1 To 1)
    For i = 1 To UBound(arr)
        var = Split(arr(i, 2), ",")
        lngCounter = 0
        For ii = 0 To UBound(var)
            If InStr(arr(i, 1), "," & var(ii) & ",") <> 0 Then
                lngCounter = lngCounter + 1
            End If
        Next ii
        res(i, 1) = lngCounter
    Next i
    Range("C1").Resize(UBound(res)).Value = res()

End Sub

=СУММПРОИЗВ(--ЕЧИСЛО(ПОИСК(ПСТР(B1;ЕСЛИ(ДЛСТР(B1)<=2;1;ЕСЛИ(ДЛСТР(B1)=4;{1;4};ЕСЛИ(ДЛСТР(B1)=7;{1;4;7};ЕСЛИ(ДЛСТР(B1)=10;{1;4;7;10}))));1);A1)))