Como destacar e contar células repetidas em uma coluna Excel

   Olá, as seguintes macros VBA, que retirei do Clube do Hardware com autorização do colega que postou, descobrem quais e quantas células estão repetidas em uma coluna, no exemplo, coluna F, em uma planilha "Cadastros" no excel que simboliza tabelas Nome/Endereço/etc, comuns no uso do programa.

   Primeiramente, organiza as células de A a Z a partir da coluna F; em seguida, verifica se um endereço em uma célula é igual ao da célula de cima e pinta tal célula. Em seguida, retoma a ordem A-Z a partir da coluna A.
   Em uma segunda macro, o excel conta quantos registros estão na tabela e atribui à variável i; depois, subtrai as células coloridas e então sabemos quantos são os endereços.


   Se você encontrou algum erro no código ou conhece um modo alternativo, quem sabe, mais simples, comente abaixo.

Sub end_repetidos()
Range("F2").Select

'organiza a coluna de A a Z
ActiveWorkbook.Worksheets("Cadastros").Sort.SortFi elds.Clear
ActiveWorkbook.Worksheets("Cadastros").Sort.SortFi elds.Add Key:=Range("F2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Cadastros").Sort
.SetRange Range("A2:M1500")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'destaca os endereços repetidos
ActiveCell.EntireColumn.Interior.Pattern = xlNone
i = -1

While ActiveCell.FormulaR1C1 <> ""
If ActiveCell.FormulaR1C1 = ActiveCell.Offset(i, 0).FormulaR1C1 Then
Selection.Interior.Color = RGB(219, 229, 241)
'With Selection.Interior
'.Pattern = xlSolid
'.PatternColorIndex = xlAutomatic
'.ThemeColor = xlThemeColorAccent1
'.TintAndShade = 0.799981688894314
'.PatternTintAndShade = 0
'End With
End If
ActiveCell.Offset(1, 0).Select
Wend

'Volta à organização normal
Range("A2").Select
ActiveWorkbook.Worksheets("Cadastros").Sort.SortFi elds.Clear
ActiveWorkbook.Worksheets("Cadastros").Sort.SortFi elds.Add Key:=Range("A2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Cadastros").Sort
.SetRange Range("A2:M1500")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

End Sub


=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*


Sub numreg()
    Dim i As Integer
    Dim j As Integer
    Dim count As Integer
    Range("F2").Select
     i = 1
    While ActiveCell.Offset(i, 0).FormulaR1C1 <> ""
    i = i + 1
    Wend
    MsgBox i
    count = i
    For j = 0 To i
        If ActiveCell.Offset(j, 0).Interior.Color = RGB(219, 229, 241) Then
        count = count - 1
        End If
    Next j
    MsgBox count
End Sub


Salve a Solidariedade na Web!