Sub KolUniq()
Dim i As Long
Dim iLastRow As Long
Dim j As Integer
Dim dicObj As Object
Dim FoundCell As Range
Dim FAdr As String
   iLastRow = Range("A7").End(xlDown).Row
   Range("B7:B" & iLastRow).ClearContents
  For i = 7 To iLastRow
    Set FoundCell = Range("A12:A31").Find(Cells(i, "A"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
      Set dicObj = CreateObject("scripting.dictionary")
      Do
       For j = 2 To 5
         If Not IsEmpty(Cells(FoundCell.Row, j)) Then
           dicObj.Item(CStr(Cells(FoundCell.Row, j))) = dicObj.Item(CStr(Cells(FoundCell.Row, j))) + 1
         End If
       Next
       Set FoundCell = Range("A12:A31").FindNext(FoundCell)
      Loop While FoundCell.Address <> FAdr
     End If
       Cells(i, "B") = dicObj.Count
  Next
End Sub

Sub dsd()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
    Dim rCell As Range
    Dim ДИАПАЗОН As Range
    Dim k1 As Range
    Dim CriterioN As String
    Dim Unique As New Collection
    On Error Resume Next
    LR = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 7 To 9
    CriterioN = Cells(i, 1).Value
        Set k1 = Range("A12:A1000000").Find(CriterioN, LookIn:=xlValues, LookAt:=xlWhole)
        k2 = Application.WorksheetFunction.CountIf(Range("A13:A" & LR), CriterioN) + k1.Row - 1
        Set ДИАПАЗОН = Range("B" & k1.Row & ":E" & k2)
            For Each rCell In ДИАПАЗОН
                If Not IsEmpty(rCell) Then
                Unique.Add rCell.Value, CStr(rCell.Value)
                End If
            Next rCell
                Cells(i, 2) = Unique.Count
    Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub