Excel VBA Planilha duplicados chama função verifica

Planilha Excel VBA duplicados chama função verifica

E xcel VBA Planilha duplicados chama função verifica Este Macro do aplicativo ms Excel vba chama uma função através de uma instrução for e verifica se existe ou não duplicados em determinado intervalo de células nas linhas, e retorna se existe ou não duplicados.

‘Função duplicados verifica se há duplicados

Public Function sbDuplicados(ByVal vRng As Range, ByRef bDuplicados As Variant, _
ByRef bUnico As Variant) As Variant
‘Variáveis determinantes
Dim vCelula As Range
Dim vQuantidade As Long
Dim vUnicos As New Collection

‘Essa intrução passa para o próximo passo se ocorrer erro
On Error Resume Next

‘ao recalcular qualquer dados na folha de planilha recalcula
‘Application.Volatile

‘verifica o intervalo e quantidade de células existentes
vQuantidade = vRng.Rows.Count * vRng.Columns.Count

‘Faz um loop (For Each) em todas as células da Area especifica
For Each vCelula In vRng
‘passará para o próximo, se a verificação caso houver duplicidade.
vUnicos.Add vCelula.Value, CStr(vCelula.Value)
Next vCelula

On Error GoTo 0

If vQuantidade > vUnicos.Count Then
sbDuplicados = bUnico
Else
sbDuplicados = bDuplicados
End If
End Function

Sub sbx_chamar_funcao()
Dim i As Long
sbx_inserir_aletorios_teste
x = Cells(Rows.Count, “c”).End(xlUp).Row
For i = 5 To Cells(Rows.Count, “c”).End(xlUp).Row
‘Cells(i, “k”) = sbDuplicados(Range(“c” & i & “:” & “G” & x), “Duplicados”, “Unicos”)
Cells(i, “k”) = sbDuplicados(Range(Cells(i, “c”), Cells(i, “g”)), “Unicos”, “Duplicados”)
If Cells(i, “k”).Value = “Unicos” Then
Cells(i, “k”).Interior.ColorIndex = 4
Else
Cells(i, “k”).Interior.ColorIndex = 6
End If
Next i
[C1].Select
End Sub

Sub sbx_inserir_aletorios_teste()
Dim vCol, vLin As Long
Application.EnableEvents = False
For vCol = 3 To 7
For vLin = 5 To Cells(Rows.Count, “a”).End(xlUp).Row
Cells(vLin, vCol).Select
Cells(vLin, vCol).Value = Int(15 * Rnd)
Next vLin
Next vCol
End Sub

Sub sbx_limpar_teste()
Dim i As Long
x = Cells(Rows.Count, “a”).End(xlUp).Row + 1 ‘ +1 para nao apagar o cabeçalho se o usuário repetir com área limpa
Range(Cells(5, “k”), Cells(x, “k”)).ClearContents
Range(Cells(5, “k”), Cells(x – 1, “k”)).Interior.ColorIndex = xlNone
End Sub