Boa tarde pessoal,
Fiz um módulo utilizando o "Filtro Avançado" para retirar dados repetidos que está funcionando perfeitamente.
Porém ao tentar fazer uma função (.xlam) aonde coloco apenas o intervalo de Dados a serem analisados e a célula
<Ativa> no momento da escolha da função seja a célula de <Saída> dos dados sem repetição.
Sei que no Excel 365 tem a função "Único" que faz isso mas tem gente que não tem dinheiro para isso, então peço
a ajuda de vocês. Alguém poderia me dar uma força?
O código é:
Option Explicit
Public Function DADOS_UNICOS(ByVal DADOS As Excel.Range)
Dim Resposta As VbMsgBoxResult
On Error Resume Next
ActiveWorkbook.Names("Extract").Delete ' DELETA O RANGE DE EXTRAÇÃO PARA NÃO COPIAR NO LUGAR ERRADO
If Application.ActiveCell = "" Then
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Area_de_extracao", RefersToR1C1:=Application.ActiveCell 'CRIA O RANGE "Area_de_extracao" NA CELULA ATUAL
Resposta = MsgBox("APESAR DA CÉLULA <ESCOLHIDA> ESTAR VAZIA, , <APAGAREI> TODOS OS DADOS DA COLUNA" & Chr(13) & Chr(13) & "DESEJA MESMO CONTINUAR ?", vbYesNo, "CUIDADO AO PROSEGUIR.")
If Resposta = vbNo Then
Exit Function
End If
ActiveCell.EntireColumn.ClearContents
Range("DADOS").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("Area_de_extracao"), Unique:=True
'CLASSIFICAR COLUNA DE RESULTADOS
ActiveCell.EntireColumn.Sort Key1:=ActiveCell.EntireColumn, Order1:=xlAscending 'Classifica em ordem crescente toda a coluna DA CELULA ATIVA
Range("Area_de_extracao").Select
ActiveWorkbook.Names("Extract").Delete ' DELETA NVAMENTE O RANGE DE EXTRAÇÃO
Exit Function
Else
ActiveWorkbook.Names("Area_de_extracao").Delete ' DELETA O RANGE DE EXTRAÇÃO PARA NÃO COPIAR NO LUGAR ERRADO
Resposta = MsgBox("A CÉLULA ESTÁ <PREENCHIDA>" & Chr(13) & Chr(13) & "- <APAGAREI> TODOS OS DADOS DA COLUNA" & Chr(13) & Chr(13) & "DESEJA MESMO CONTINUAR ?", vbYesNo, "CUIDADO AO PROSEGUIR.")
If Resposta = vbNo Then
Exit Function
End If
ActiveCell.EntireColumn.ClearContents
ActiveWorkbook.Names.Add Name:="Area_de_extracao", RefersToR1C1:=Application.ActiveCell 'CRIA O RANGE "Area_de_extracao" NA CELULA ATUAL
Application.ActiveCell = ""
Range("DADOS").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("Area_de_extracao"), Unique:=True
'CLASSIFICAR COLUNA DE RESULTADOS
ActiveCell.EntireColumn.Sort Key1:=ActiveCell.EntireColumn, Order1:=xlAscending 'Classifica em ordem crescente toda a coluna DA CELULA ATIVA
Range("Area_de_extracao").Select
ActiveWorkbook.Names("Extract").Delete ' DELETA NVAMENTE O RANGE DE EXTRAÇÃO
End If
End Function
Vídeo recomendado
https://youtu.be/diWPPPhW-9E
https://youtu.be/diWPPPhW-9E