Escola Saberexcel VBA Estudos - o site de quem precisa aprender Macros ms Excel VBA

Esses macro e Função do aplicativo Microsoft Excel VBA(Visual Basic Application), retorna os o total de ítens ou nomes não duplicados, em determinada coluna. Observe que a título didático usei também o VBA(Visual Basic Application) para chamar a função e retornar o valor (totalizando os nomes não duplicados) em mensagem e também direcionado para célula B1 na folha de planilha principal.
Espero que o exemplo possa lhe ser útil. também inserí umas variáveis Constante com finalidade didática.
Fique com Deus, Expedito Marcondes.


Const a = "Escola Saberexcel VBA Estudos®"
Const s = vbInformation

Function ContarValorUnico(Intervalo As Range)
Dim iValoresUnicos As New Collection
On Error Resume Next

For Each vCelulas In Intervalo
iValoresUnicos.Add vCelulas.Value, CStr(vCelulas.Value)
Next vCelulas


On Error GoTo 0
ContarValorUnico = iValoresUnicos.Count
End Function

'observem que o endereço do intervalo (Range()) área é expandido pela variável (x)
'------
Sub md_chamar_funcao()
Dim X As Integer
X = Saber1.Range("A" & Application.Rows.Count).End(xlUp).Row

[b1] = ContarValorUnico(Range("a1" & ":A" & CStr(X)))
MsgBox "Existem [ " & ContarValorUnico(Range("a1" & ":A" & CStr(X))) & " ] Valores não duplicados ", s, a
End Sub


Aprenda tudo sobre planilhas do Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Escola Saberexcel VBA Estudos® - Treinamentos com Macros, Fórmulas e Funções.



 

Saberexcel - o site de quem precisa aprender macros microsoft excel vba

Esse macro do Aplicativo Microsoftexcel Excel VBA, com auxilio de uma inputbox para o critério de deleção de linhas preserva a linha com ítem escolhido ou seja preserva valores únicos ou ao contrário deleta os únicos e preserva os duplicados, pois a deleção de dá pelo critério do nome contido na fórmula na coluna (C) - 'Único" ou "Duplicado". no final da página há um link para baixar o exemplo de planilha contendo o macro abaixo.
Espero que o exemplo possa ajudá-los.
'- - - - - - - - - - -- - - - - - - - - - - - - - - - - - - - -
A Fórmula usada para retornar o critério dos duplicados é:
'=SE(CONT.SE($A$2:B2;B2)>1;"Duplicado";"Único")
'- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Sub Loop_for_next_preservar_palavra_exluir_linha()
vCriterio = InputBox("Digite a palavra que desejar preservar:", "Escola Saberexcel VBA Estudos®", "Único")
If vCriterio = Cancel Then 'caso o usuário resolva cancelar a operação para nao ocorrer erro.
Exit Sub
End If

If CStr(vCriterio) <> "Único" And CStr(vCriterio) <> "Duplicado" Then
MsgBox ("valores não existente, digite novamente")
vCriterio = InputBox("Digite a palavra que deseja preservar:", "Escola Saberexcel VBA Estudos®", "Único")
If vCriterio = Cancel Then'caso o usuário resolva cancelar a operação para nao ocorrer erro.
Exit Sub
End If
End If

For i = ActiveSheet.Cells(65536, 1).End(xlUp).Row To 2 Step -1
If Cells(i, 3).Value <> vCriterio Then
Cells(i, 3).EntireRow.Delete Shift:=xlUp
End If
Next i

MsgBox ("Linhas contendo dados [ ") & vCriterio & " ] foram PRESERVADAS!!!", _
vbInformation, "Saberexcel - o site das macros"
End Sub

Sub copiar_teste()
[a].Copy [b] 'aqui renomeiei a área 'a' (Plan(Auxiliar)(A1:D21)) a ser copiada e célula(A1) como [b] para receber os dados 'a'
End Sub
' - - - - - - - - - - - - - - - - - - - - - - -
Aprenda tudo sobre planilhas do Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Escola Saberexcel VBA Estudos® - Treinamentos com Macros, Fórmulas e Funções.

Escola Saberexcel VBA Estudos® - Treinamentos com Macros, Fórmulas e Funções

Esse macro do aplicativo Microsoft Excel VBA(Visual Basic Application), mescla células duplicadas, deletando em parte as células duplicadas
baixe o exemplo de planiha no final da página, há uma macro para copiar os dados para facilitar o teste.
Fique com Deus, Expedito Marcondes
'veja nosso curso completo microsoft com vídeo aulas (Aprenda programar, brincando com Excel é bem divertido)
' - - - - - - - - - - - - - - - - - - - - - - - - - - -
Sub sbx_fusao_duplicados_vertical()
Dim L As Long ' linha
Dim d As Long ' duplicados
Dim c As Integer ' coluna

Const minL = 1 ' linha inicial
Const maxL = 15 ' linha final
Const minC = 1 ' inicio coluna
Const maxC = 3 ' fim coluna

Application.ScreenUpdating = False
Application.DisplayAlerts = False

For c = minC To maxC 'colunas
For L = minL To maxL 'linhas

For d = L + 1 To maxL
If (Cells(L, c) <> Cells(d, c)) Then Exit For
Next d

If d > L + 1 Then
With Cells(L, c).Resize(d - L, 1)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
End If
Next L
Next c

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Saber1.[f9].Value = "Area com Duplicados foram Mescladas!"
End Sub
' - - - - - - - - - - - - - - - - - - - - - - - - - - -
Sub copiar_teste()
Saber1.Cells.Clear
[a].Copy [b] 'renomeei intervalo de células(a) Saber2[a1:c22] e b(a1)Plan1
Saber1.[f9].Value = "Execute o macro para mesclar areas com duplicados!"
End Sub



Aprenda tudo sobre planilhas do Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Escola Saberexcel VBA Estudos® - Treinamentos com Macros, Fórmulas e Funções.



Baixe o exemplo de planilha contendo os macros acima:
Registre-se em nosso site, há muitos donwloads na áre livre para Registrados,
Fiquem com Deus.  Expedito Marcondes.

Essa macro do Aplicativo Microsoft Excel VBA, juntamente com uma função retornam valores únicos em determinada coluna coluna,
observe que a macro copia para coluna(B) valores únicos existentes na coluna(A), valores não duplicados.

Sub Copiar_valores_unicos()
Dim coll As Collection, i As Long
Set coll = RetornaValorUnico(Range("A1:A100"))
If coll Is Nothing Then Exit Sub

Range("C1:C100").Clear
For i = 1 To coll.Count
Range("C1").Offset(i - 1, 0).Formula = coll(i)
Next i
End Sub

Function RetornaValorUnico(KeyRange As Range, Optional ItemRange As Range) As Collection
Dim r As Long, c As Long, varItem As Variant, strKey As String
If Not KeyRange Is Nothing Then
Set RetornaValorUnico = New Collection
With KeyRange
For c = 1 To .Columns.Count
For r = 1 To .Rows.Count
strKey = vbNullString
varItem = vbNullString

On Error Resume Next
strKey = Trim(CStr(.Cells(r, c).Value))

If Not ItemRange Is Nothing Then
varItem = ItemRange.Cells(r, c).Value
Else
varItem = .Cells(r, c).Value
End If

If Len(strKey) > 0 Then
RetornaValorUnico.Add varItem, strKey
End If
On Error GoTo 0
Next r
DoEvents
Next c
End With
If RetornaValorUnico.Count = 0 Then
Set RetornaValorUnico = Nothing
End If
End If
End Function

Sub limpar_teste()
[C:C].ClearContents
End Sub


Aprenda Aplicativo Microsoft Excel VBA com SaberExcel - o site das macros

Saberexcel - o Site das Macros
Essa macro do Aplicativo Microsoft Excel VBA, deleta dados duplicados em determinada região, voce poderá selecionar manualmente a região que deseja examinar e deletar todos os dados duplicados, da também para verificar os dados duplicados e não duplicados, só adptar código na macro, observe as cores do interior da célula, as que a condição if for Verdadeira e ou falsa.

Sub Duplicados_ou_nao_Duplicados()
Dim sbColecao As New Collection, Cell As Range, sbRegiao As Range
If [M12].Value = "Dados duplicados deletados" Then
MsgBox ("Dados duplicados já deletados, insira novamente novos dados"), vbCritical, "Saberexcel - site das Macros"
Exit Sub
End If

On Error Resume Next
Set sbRegiao = Application.InputBox("Selecione área [range a examinar]", "Saberexcel - site das macros", Type:=8)
If IsEmpty(sbRegiao) Then Exit Sub

For Each Cell In sbRegiao
If Cell.Value <> "" Then
sbColecao.Add Cell.Value, CStr(Cell.Value)
If Err <> 0 Then
Err.Clear
Cell.ClearContents
'Cell.Interior.ColorIndex = 43
Else
'Cell.ClearContents
Cell.Interior.ColorIndex = 6
End If
End If
Next Cell
[M12].Value = "Dados duplicados deletados"
End Sub

Sub copiar_para_teste()
Sheets("Plan2").Select
Range("A1:J10").Select
Selection.Copy
Sheets("Plan1").Select
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
[M12].Value = "Novos dados inseridos para teste"
End Sub

Aprenda sobre Aplicativo Microsoft Excel VBA (SaberExcel)