Boa tarde Cris

Baixe a planilha e veja se é isto que você deseja:

Se a resposta foi útil, clique na mãozinha que fica do lado da ferramenta Citar.

Dê retorno.

[]s

Patropi, dessa forma não atende pq as palavras que uso são dinâmicas. Conseguir encontrar um exemplo que atendeu a minha necessidade, segue o código para estudos.

Obrigado!

Public Function ContarRecorrencias() '(objPlanilha As Worksheet)
Dim lngRow As Long
Dim lngCol As Long
Dim objRange As Range
Dim objRngFind As Range
Dim objPlanilha As Worksheet

    Set objPlanilha = ThisWorkbook.Sheets("Valores")
    Set objRange = ThisWorkbook.Sheets("Contador").Range("A:B")
    objRange.Cells(1, 1) = "Valor"
    objRange.Cells(1, 2) = "Nº Ocorrências"
    With objRange.Range("A1:B1")
        .Font.Bold = True
        .Interior.ColorIndex = 10
    End With
    'Le a planilha celula a celula e conta os valores
    For lngCol = 1 To objPlanilha.Columns.Count
        lngRow = 1
        If objPlanilha.Cells(lngRow, lngCol) = Empty Then Exit For
        For lngRow = 1 To objPlanilha.Rows.Count
            If objPlanilha.Cells(lngRow, lngCol) = Empty Then Exit For
            Set objRngFind = objRange.Find(objPlanilha.Cells(lngRow, lngCol), , xlValues)
            If objRngFind Is Nothing Then
                objRange.Cells(WorksheetFunction.CountA(objRange.Columns(1)) + 1, 1).Value = objPlanilha.Cells(lngRow, lngCol).Value
                objRange.Cells(WorksheetFunction.CountA(objRange.Columns(2)) + 1, 2).Value = 1
            Else
                objRange.Cells(objRngFind.Row, 2) = objRange.Cells(objRngFind.Row, 2).Value + 1
            End If
        Next
    Next
    'ordena
    objRange.Sort objRange.Cells(1, 2), xlDescending, , , , , , xlYes
    'remove os menores que 3
    For lngRow = 2 To objRange.Rows.Count
        If objRange.Cells(lngRow, 2) < 0 Then
            objRange.Range(objRange.Cells(lngRow, 1), objRange.Cells(objRange.Rows.Count, 2)).Clear
            Exit For
        End If
    Next
End Function