Este fórum está sendo desativado

[AndreSpecker]

Boas pessoal, eu tenho uma lista suspensa com condicional que cria outra lista suspensa com dados, teria como esses dados da segunda lista não se repetirem? Vi que daria para fazer com a função Único, mas meu Excel é 2013, e não tem essa função.

[PHSabater]

@AndreSpecker, boa noite.
Vi que está utilizando Macros para fazer algumas rotinas, insira em algum módulo a macro abaixo, ela vai gerar uma lista única na sua aba Tabelas na coluna D, com isso só redirecionar sua lista para essa coluna.

Código: Selecionar todos

Public Sub ListaUnica()
    Dim lLinha As Long
    Dim lLista As Long
    Dim Existe As Boolean
    
    lLinha = 2
    lLista = 1
    Existe = fase
    Do Until Plan1.Cells(lLinha, 2) = ""
        Do Until Plan3.Cells(lLista, 4) = ""
            If Plan3.Cells(lLista, 4) = Plan1.Cells(lLinha, 4) Then
                Existe = True
                Exit Do
            End If
        lLista = lLista + 1
        Loop
        If Existe = False Then
            Plan3.Cells(lLista, 4) = Plan1.Cells(lLinha, 4)
        End If
    lLinha = lLinha + 1
    lLista = 1
    Existe = False
    Loop
End Sub

[AndreSpecker]

Obrigado pela ajuda, mas não deu muito certo, ele pegou somente os dois primeiros itens da tabela Dados.

[osvaldomp]

Experimente o código abaixo no lugar do existente no módulo da planilha Pesquisa.
O código atual está contido no código abaixo.

Código: Selecionar todos

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim k As Long, LR As Long
  Application.ScreenUpdating = False
  If Target.Address = "$C$1" Then
   [C2].Validation.Delete: [C2] = ""
   If Target.Value <> "" Then
    With Sheets("Dados")
     .[W:W].Clear
     LR = .Cells(Rows.Count, 2).End(3).Row
     k = .[A1:L1].Find([C1]).Column
     .Range(.Cells(2, k), .Cells(LR, k)).Copy .[W1]
     .Range("W1:W" & LR - 1).RemoveDuplicates Columns:=1, Header:=xlNo
     .Range("W1:W" & .Cells(Rows.Count, 23).End(3).Row).Sort Key1:=.[W1], Order1:=xlAscending
     [C2].Validation.Add Type:=xlValidateList, Formula1:="=Dados!W1:W" & .Cells(Rows.Count, 23).End(3).Row
     [C2].NumberFormat = IIf(k = 5, "dd/mm/yyyy", "General")
     [C2].Activate
    End With
   End If
  ElseIf Target.Address = "$C$2" Then
   If [C4] <> "" Then Range("C4:M" & Cells(Rows.Count, 3).End(3).Row).ClearContents
    If Target.Value <> "" Then
     Sheets("Dados").Range("B1:L800").AdvancedFilter Action:=xlFilterCopy, _
      CriteriaRange:=Range("C1:C2"), CopyToRange:=Range("C4"), Unique:=False
    Call ColoriPesquisa
   End If
 End If
End Sub

#
obs.
1. antes de testar desfaça a mesclagem em C2:E2 da planilha Pesquisa. Células mescladas são desnecessárias, inúteis e podem provocar erros em macros e em fórmulas.
2. o código utiliza a coluna W da planilha Dados como coluna auxiliar

[PHSabater]

@AndreSpecker, deve não ter linkado a "Lista"... segue o arquivo com as alterações.

[AndreSpecker]

PHSabater, testei novamente e não funcionou, já com o do osvaldomp foi exatamente como queria, muito obrigado aos dois pela ajuda

[AndreSpecker]

@osvaldomp poderias dar uma checada, eu fiz umas alterações na planilha, e alterou algumas colunas, tentei com o codigo abaixo, mas talvez tenha que alterar algum dado que não estou acertando, poderias verificar?
Os dados na coluna W não estão sendo "criados"

Código: Selecionar todos

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim k As Long, LR As Long
  Application.ScreenUpdating = False
  If Target.Address = "$E$1" Then
   [E2].Validation.Delete: [E2] = ""
   If Target.Value <> "" Then
    With Sheets("Dados")
     .[W:W].Clear
     LR = .Cells(Rows.Count, 2).End(3).Row
     k = .[A1:O1].Find([E1]).Column
     .Range(.Cells(2, k), .Cells(LR, k)).Copy .[W1]
     .Range("W1:W" & LR - 1).RemoveDuplicates Columns:=1, Header:=xlNo
     .Range("W1:W" & .Cells(Rows.Count, 23).End(3).Row).Sort Key1:=.[W1], Order1:=xlAscending
     [E2].Validation.Add Type:=xlValidateList, Formula1:="=Dados!W1:W" & .Cells(Rows.Count, 23).End(3).Row
     [E2].NumberFormat = IIf(k = 5, "dd/mm/yyyy", "General")
     [E2].Activate
    End With
   End If
  ElseIf Target.Address = "$E$2" Then
   If [E4] <> "" Then Range("E4:R" & Cells(Rows.Count, 3).End(3).Row).ClearContents
    If Target.Value <> "" Then
     Sheets("Dados").Range("B1:O800").AdvancedFilter Action:=xlFilterCopy, _
      CriteriaRange:=Range("E1:E2"), CopyToRange:=Range("E4"), Unique:=False
    Call ColoriPesquisa
   End If
 End If
End Sub

[osvaldomp]

Disponibilize o novo arquivo Excel com o código que passei (sem qualquer alteração) e informe com exatidão quais as mudanças que você fez nas planilhas com relação ao arquivo anteriormente disponibilizado.

[AndreSpecker]

Fiz umas correções aqui e deu tudo certo, obgg