Vídeo recomendado
https://youtu.be/diWPPPhW-9E

Função em VBA (.xlam)

Dúvidas gerais sobre Excel
Avatar do usuário
TARSA
Colaborador
Colaborador
Mensagens: 36
Registrado em: Dom Set 11, 2016 5:04 pm

Função em VBA (.xlam)

Mensagem por TARSA »

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


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Responder