Private Sub Worksheet_Activate()
arrV = Sheets(1).[a1:d3]: arrM = Sheets(2).[a1:d3]
For i = 2 To 3
  For j = 2 To 4
  s = 0
    If Len(arrV(i, j)) < 4 Then
      For h = 1 To Len(arrV(i, j))
      If CStr(arrM(i, j)) Like "*" & Mid(arrV(i, j), h, 1) & "*" Then s = s + 1
      Next h
    End If
  Cells(i, j) = s
  Next j: Next i
End Sub

Option Explicit
Sub qwe()
Dim a$, b$, i%, ii%, iii%, summ%
For i = 2 To 4
    For ii = 2 To 3
        a = CStr(Sheets(2).Cells(ii, i).Value)
        b = CStr(Sheets(1).Cells(ii, i).Value)
            For iii = 1 To Len(b)
                If InStr(1, a, Mid(b, iii, 1)) Then summ = summ + 1 Else summ = summ - 1
            Next iii
            If summ < 0 Then summ = 0
            Sheets(3).Cells(ii, i).Value = summ
            summ = 0
    Next ii
Next i
End Sub

Sub qwe()
Dim kolvo_otv%, kolvo_zad%
kolvo_otv = InputBox("Введите количество отвечающих")
kolvo_zad = InputBox("Введите количество заданий")


For i = 1 To kolvo_otv

'заполнение массивов
    fst = Sheets(1).Range(Sheets(1).Cells(i + 2, 3), Sheets(1).Cells(i + 2, kolvo_zad + 2))
        If Sheets(1).Cells(i + 2, 2) = 1 Then
            snd = Sheets(2).Range(Sheets(2).Cells(3, 2), Sheets(2).Cells(3, kolvo_zad + 1))
        Else
            snd = Sheets(2).Range(Sheets(2).Cells(4, 2), Sheets(2).Cells(4, kolvo_zad + 1))
        End If
'конец заполнения массивов

matr = fst 'инициализация массива оценок

'проверка ответов
For ii = 1 To UBound(fst, 2)
otvet = CStr(fst(1, ii))
proverka = CStr(snd(1, ii))
    
    For iii = 1 To Len(otvet)
        If InStr(1, proverka, Mid(otvet, iii, 1)) Then summ = summ + 1 Else summ = summ - 1
    Next iii
    
    If summ < 0 Then summ = 0
    matr(1, ii) = summ
    summ = 0
            
Next ii
'конец проверки ответов

'заполнение протокола
Sheets(3).Cells(i + 2, 1) = Sheets(1).Cells(i + 2, 1)
Sheets(3).Cells(i + 2, 2) = Sheets(1).Cells(i + 2, 2)
Sheets(3).Range("C" & i + 2).Resize(1, UBound(fst, 2)) = matr
'конец заполнение протокола

Next i
End Sub