Result
Code
DimwsAsWorksheetDimUltimaLinhaAsLong,iAsLongDimValorTrimAsStringDimunicosAsCollectionDimintervaloAsrangeSetunicos=NewCollectionSetws=ThisWorkbook.Worksheets("Planilha1")
With ws
'Última linha da coluna "A"
UltimaLinha = .Cells(Rows.Count, "A").End(xlUp).Row
Set intervalo = .range("$A$1:$A$" & UltimaLinha)
On Error Resume Next
'Cria uma Collection de valores Únicos e não vazios
For Each celula In intervalo
ValorTrim = Trim(celula)
If ValorTrim = "" Then GoTo ProximoValor
unicos.Add ValorTrim, ValorTrim
ProximoValor:
Next celula
On Error GoTo 0
'Gera uma Lista com os valores únicos e não vazios
For i = 1 To unicos.Count
Lista = Lista & unicos.Item(i) & ","
Next i
With .range("B1:B1").Validation
'Apaga a Validação existente
.Delete
'Cria uma validação com os dados da lista
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Lista
End With
End With