Usuários do Excel
Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

Colorir_Duplicidades_de_Cor_Diferente_Para_Duplicidades_Diferente

Ir para baixo

Colorir_Duplicidades_de_Cor_Diferente_Para_Duplicidades_Diferente Empty Colorir_Duplicidades_de_Cor_Diferente_Para_Duplicidades_Diferente

Mensagem por alexandrevba Dom Set 02, 2012 12:46 pm

Boa tarde!!!

Veja Imagem:
http://imageshack.us/content_round.php?page=done&l=img855/1173/duplicidadescolorir.jpg
Código:
Sub InteriorColorDuplicados()

    Dim LLoop As Integer
    Dim LTestLoop As Integer
    Dim LClearRange As String
   
    Dim Lrows As Integer
    Dim LRange As String
   
    'Variaveis para a Coluna e Valor
  Dim LChangedValue As String
    Dim LTestValue As String
   
    'Cor Inicial
  Dim sCor As Integer
    sCor = 1

    'Teste em 20 linhas na planilha
  Lrows = 500 'Atere aqui para mais Linhas
  LLoop = 2
   
    'Limpa a formatação anterior
  LClearRange = "C2:C" & Lrows
    Range(LClearRange).Interior.ColorIndex = xlNone
   
    'Verifica primeiro as 20 linhas na planilha
  While LLoop <= Lrows
        'Define a Coluna C
      LChangedValue = "C" & CStr(LLoop)
       
        If Len(Range(LChangedValue).Value) > 0 Then
       
            'Testa cada valor se são unicos
          LTestLoop = 2
            While LTestLoop <= Lrows
                If LLoop <> LTestLoop Then
                    LTestValue = "C" & CStr(LTestLoop)
                    'Se o valor for duplicado
                  If (Range(LChangedValue).Value = Range(LTestValue).Value) Then
                        'Altera a cor de Fundo da celula
                      Range(LChangedValue).Interior.ColorIndex = sCor
                        Range(LTestValue).Interior.ColorIndex = sCor
                    End If
                       
                End If
               
                LTestLoop = LTestLoop + 1
            Wend
           
        End If
       
        LLoop = LLoop + 1
 
        'Soma + 1 para a proxima Cor
      sCor = sCor + 1
    If sCor = 20 Then
   
      sCor = 1
        End If
    Wend
   
End Sub
alexandrevba
alexandrevba
Intermediário
Intermediário

Mensagens : 222
Data de inscrição : 26/06/2012
Localização : Serra-ES

Ir para o topo Ir para baixo

Ir para o topo


 
Permissões neste sub-fórum
Não podes responder a tópicos