Localizar duplicados e formatar baseado em critério

Question

Boa noite

Formatar numeros duplicados  baseado em um critério. O que o código precisa fazer:

Procurar no intervalo A2:C51__E2:G51__I2:K51__M2:O51, números  iguais e formatar, baseado no valor do critério dado, deixando visível apenas a quantidade de números iguais desejado. "n"

Exemplo:

No intervalo  A2:C51__E2:G51__I2:K51__M2:O51, temos  15 números  20, informamos que o valor de  n = 2, então o código procura e formata  13 desses números  20  deixando apenas 2 numero 20  sem formatação,  assim como para qualquer numero da lista  que exceda o valor de "n".

O código postado só atua em um único intervalo.

Os referidos intervalos tem o plano de fundo das células preto e fonte branca.

Muitissimo grato se puderem ajudar.

Option Compare Text
Sub Compara_Formata()
Dim j As Long, l As Long, n As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Range("A2:A51").Interior.Color = 0
n = 2
l = Range("B" & Rows.Count).End(xlUp).Row
Columns("A:A").Insert shift:=xlToRight
For j = 1 To l
Range("A" & j).FormulaLocal = "=cont.se($B$1:$B" & j & ";$B" & j & ")"
If Range("A" & j).Value > n Then Range("B" & j).Font.Color = vbBlack
Next j
Range("A:A").EntireColumn.Delete
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Answer 1

"assim como para qualquer numero da lista  que exceda o valor de "n"."

Acho que você quis dizer "assim como para qualquer numero da lista  que exceda o valor de "20".", não?

Veja um exemplo abaixo:

Sub fMain()
    Dim lngN As Long
    Dim lngBusca As Long
    Dim rng As Range
    Dim col As Collection
    Dim lng As Long
    
    lngBusca = InputBox("Informe o número a ser procurado.")
    lngN = InputBox("Informe N")
    
    Set col = New Collection
    For Each rng In Range("A2:C51,G51:I2,M2:O51")
        If rng >= lngBusca Then
            col.Add rng
        End If
    Next rng
    
    For lng = col.Count To col.Count - lngN + 1 Step -1
        Set rng = col(lng)
        rng.Interior.Color = vbBlack
        rng.Font.Color = vbWhite
    Next lng
End Sub

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 2

Benzadeus, é para qualquer numero mesmo que exceda  o valor de "n". Dentro das listas vai haver vários duplicados, então preciso que o código formate qualquer duplicado que seja maior do que o valor de "n". O valor 20, é para efeito de comparação, haja vista que haverá duplicados com quantidades diferentes de números.

Grato por ter respondido

Answer 3

Sub fMain()
    Const cstrBanco As String = "A2:C51,G51:I2,M2:O51"
    
    Dim lngN As Long
    Dim dblBusca As Double
    Dim rng As Range
    Dim col As Collection
    Dim lng As Long
    Dim lngOccur As Long
    Dim strFirst As String
    
    dblBusca = InputBox("Informe o valor de corte.")
    lngN = InputBox("Informe N")
    
    Set col = New Collection
    On Error Resume Next
    For Each rng In Range(cstrBanco)
        If rng >= dblBusca Then
            col.Add CStr(rng), CStr(rng)
        End If
    Next rng
    On Error GoTo 0
    
    For lng = 1 To col.Count
        lngOccur = 0
        Set rng = Range(cstrBanco).Find(col(lng))
        strFirst = rng.Address
        Do
            lngOccur = lngOccur + 1
            If lngOccur > lngN Then
                rng.Interior.Color = vbBlack
                rng.Font.Color = vbWhite
            End If
            Set rng = Range(cstrBanco).FindNext(rng)
        Loop While rng.Address <> strFirst
    Next lng
End Sub

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 4

1	1	2
3	4	5
4	4	6
7	8	9
9	10	11

Benzadeus, bateu na "trave" a solução. Vamos imaginar que o código acima atue somente no intervalo A1:C5 e que o N informado seja igual a 1, então os duplicados formatados estão sublinhados. Resultado final: 1 2 3 4 5 6 7 8 9 10 11. O mesmo valendo para qualquer valor de N. Não entendi muito bem o"valor de corte". Acho até que seja desnecessário, mas enfim... 

Answer 5

Sub fMain()
    Cells.Style = "Normal"
    Cells.HorizontalAlignment = xlCenter
    
    Const cstrBanco As String = "A2:C51,G51:I2,M2:O51"
    
    Dim lngN As Long
    Dim rng As Range
    Dim col As Collection
    Dim lng As Long
    Dim lngOccur As Long
    Dim strFirst As String
    
    lngN = InputBox("Informe N")
    
    Set col = New Collection
    On Error Resume Next
    For Each rng In Range(cstrBanco)
        If rng >= lngN Then
            col.Add CStr(rng), CStr(rng)
        End If
    Next rng
    On Error GoTo 0
    
    For lng = 1 To col.Count
        lngOccur = 0
        Set rng = Range(cstrBanco).Find(col(lng), , , xlWhole)
        strFirst = rng.Address
        Do
            lngOccur = lngOccur + 1
            If lngOccur > lngN Then
                rng.Interior.Color = vbBlack
                rng.Font.Color = vbWhite
            End If
            Set rng = Range(cstrBanco).FindNext(rng)
        Loop While rng.Address <> strFirst
    Next lng
End Sub

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 6

Bom dia

Excelente solução, valeu. Muito obrigado