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.

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.

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)

Estes exemplo de FC(Formatação Condicional) do Aplicativo Microsoft Excel, usando fórmulas como Formatação condicional e alguns CheckBoxes de acionando os CheckBoxes localiza os duplicados em cada coluna, através de: Formatação Condicional >> Fórmulas >> e Macros

Seleciona celulas ir >> Formatar >Formatação Condicional e ver o que foi implantado
Observe que as caixas de Seleção (CheckBox) estão diretamente ligada a uma célula (nomeada)
Por exemplo Caixa de Seleção1 = ligada à célula(A1)
Por exemplo Caixa de Seleção2 =DupeLink(célula nomeada) = $I$1
Por exemplo Caixa de Seleção1 =$I$1
Observe os nomes dos ranges para entender melhor como foi feito esta planilha,
poderá lhe muito útil em suas aplicações

A coluna(A) tem essa formula na Formatação condiconal
=E($A3>=FirstNum;$A3<=SecondNum;CheckBoxLink) 'Células nomeadas

A coluna(F) tem essa formula na Formatação condiconal
=E(CONT.SE($F$3:$F$100;$F3)>1;DupeLink;$F3<>"") 'Células nomeadas

coluna(H) - tem essa fórmula na formatação condicional
=E(CONT.SE($H3:$H$100;$H3)>1;CONT.SE($H$3:$H3;$H3)=1;DupeLink2;$H3<>"") 'Células nomeadas




Aplicativo Microsoft Excel VBA - SaberExcel - o site das macros