Colorir_Duplicidades_de_Cor_Diferente_Para_Duplicidades_Diferente
Página 1 de 1
Colorir_Duplicidades_de_Cor_Diferente_Para_Duplicidades_Diferente
Boa tarde!!!
Veja Imagem:
http://imageshack.us/content_round.php?page=done&l=img855/1173/duplicidadescolorir.jpg
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- Intermediário
- Mensagens : 222
Data de inscrição : 26/06/2012
Localização : Serra-ES
Página 1 de 1
Permissões neste sub-fórum
Não podes responder a tópicos
|
|