Опять сумма. Теперь при условии

[SAS888]

Если так, то это не будет соответствовать Вашему примеру в файле "FANTOM.EXP".

Sub Fantom()

    Dim x As Object, Fst As String, i As Long, j As Long
    Application.ScreenUpdating = False
    Columns("F").Interior.ColorIndex = xlNone
    For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
        Set x = Columns("C").Find(what:=Cells(i, "B"), LookAt:=xlWhole)
        If Not x Is Nothing Then
            Fst = x.Address: j = 0
            Do
                j = j + 1
                Set x = Columns("C").FindNext(x)
            Loop While Fst <> x.Address
            Cells(i, "F") = j
        End If
    Next
    
    For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
        If Cells(i, "D") = "fantom" Then
            Set x = Columns("B").Find(what:=Cells(i, "C"), LookAt:=xlWhole)
            If Not x Is Nothing Then
                Cells(x.Row, "F") = Cells(x.Row, "F") + Cells(i, "F")
                Cells(x.Row, "F").Interior.ColorIndex = 36
            End If
        End If
    Next
    
    For i = 2 To Cells(Rows.Count, "F").End(xlUp).Row
        If Cells(i, "F").Interior.ColorIndex = 36 Then Cells(i, "F") = Cells(i, "F") - 1
    Next

End Sub

P.S. Здесь я еще сделал подсветку цветом. Если не надо - в самом конце процедуры вставьте

Columns("F").Interior.ColorIndex = xlNone

[jungo]

Сообщение от SAS888

Если так, то это не будет соответствовать Вашему примеру в файле "FANTOM.EXP".

P.S. Здесь я еще сделал подсветку цветом.

Ты, ты ... Нет слов!!!
Низкий поклон!!!

* Jungo разорванный лежит и бьется в конвульсиях от счастья!