Sub data1()
Dim arr, i As Integer, s As String, dic As Object, lr As Long
Set dic = CreateObject("scripting.dictionary")
With Sheet1
lr = .Range("A" & Rows.Count).End(xlUp).Row
If lr = 1 And .Range("a1").Value = Empty Then Exit Sub
arr = .Range("A1:A" & lr).Value
For i = 1 To UBound(arr, 1)
If arr(i, 1) <> Empty Then
If Not dic.exists(arr(i, 1)) Then
dic.Add arr(i, 1), "KK"
If s = Empty Then
s = arr(i, 1)
Else
s = s & "," & arr(i, 1)
End If
End If
End If
Next i
.Range("E1:E3").Validation.Delete
.Range("e1:e3").Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=s
End With
End Sub
Sub data2()
Dim arr, i As Integer, s As String, lr As Long, dk As String
With Sheet1
lr = .Range("A" & Rows.Count).End(xlUp).Row
arr = .Range("A1:b" & lr).Value
dk = .Range("E1").Value
For i = 1 To UBound(arr, 1)
If UCase(arr(i, 1)) = UCase(dk) Then
If s = Empty Then
s = arr(i, 2)
Else
s = s & "," & arr(i, 2)
End If
End If
Next i
If Len(s) = 0 Then Exit Sub
.Range("f1").Validation.Delete
.Range("f1").Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=s
End With
End Sub
.
