none
Localizar duplicados e formatar baseado em critério RRS feed

  • Pergunta

  • 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, 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



    domingo, 26 de maio de 2013 02:37

Respostas

  • 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

    terça-feira, 28 de maio de 2013 22:10
    Moderador

Todas as Respostas

  • "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

    segunda-feira, 27 de maio de 2013 13:44
    Moderador
  • 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


    segunda-feira, 27 de maio de 2013 14:52
  • 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

    segunda-feira, 27 de maio de 2013 16:43
    Moderador
  • 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... 


    segunda-feira, 27 de maio de 2013 18:08
  • 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

    terça-feira, 28 de maio de 2013 22:10
    Moderador
  • Bom dia

    Excelente solução, valeu. Muito obrigado

    quarta-feira, 29 de maio de 2013 10:59