Sub FindAllDup()
Dim iSh As Worksheet
Dim iRng As Range
Dim iCell As Range
Dim I&, iKey
iStr = Split(Trim(Range("C4")))
On Error Resume Next
With CreateObject("Scripting.Dictionary")
    For I = 0 To UBound(iStr)
        For Each iSh In Worksheets
            If iSh.Name <> "Поиск" Then
                Set iRng = iSh.UsedRange.SpecialCells(xlCellTypeConstants, xlTextValues)
                If Not iRng Is Nothing Then
                    For Each iCell In iRng.Cells
                        If iCell.Text Like "*" & iStr(I) & "*" Then
                            .Add iCell.Text, 1
                            If Err <> 0 Then
                                .Item(iCell.Text) = .Item(iCell.Text) + 1
                                Err.Clear
                            End If
                        End If
                    Next
                End If
                Set iRng = Nothing
            End If
        Next
    Next
    ReDim arr(0 To UBound(.Keys), 0 To 1): I = 0
    For Each iKey In .Keys
        arr(I, 0) = .Item(iKey)
        arr(I, 1) = iKey
        I = I + 1
    Next
    Worksheets("Поиск").Range("E6").Resize(UBound(arr) + 1, 2) = arr
End With
End Sub