Kodlarda aşağıda excelin.Kodlar A,B ve C sütununa tıklayınca çalışıyor.Kabaca hazırladım kodları test amaçlı video için.
Kod:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim scr As New Scripting.Dictionary
Dim i As Integer
'--------------------------A sütununa göre------------------------------------------
If Not Intersect([A:A], Target) Is Nothing Then
For i = 1 To Cells(Rows.Count, 1).End(3).Row
If Cells(i, 1).Value <> "" Then scr(Cells(i, 1).Value) = scr(Cells(i, 1).Value)
Next
With Selection.Validation
.Delete
On Error GoTo var1
.Add Type:=xlValidateList, Formula1:=Application.Transpose(Join(scr.Keys, ","))
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = False
.ShowError = False
GoTo son
var1:
If scr.Count = 0 Then GoTo son
If Target.Offset(0, -1).Value = "" Then GoTo son
.Add Type:=xlValidateList, Formula1:=Target.Offset(0, -1).Value
End With
End If
'--------------------------B sütununa göre------------------------------------------
If Not Intersect([B:B], Target) Is Nothing Then
For i = 1 To Cells(Rows.Count, 1).End(3).Row
If Target.Offset(0, -1).Value = Cells(i, 1).Value Then
If Cells(i, 2).Value <> "" Then
scr(Cells(i, 2).Value) = scr(Cells(i, 2).Value)
End If
End If
Next
With Selection.Validation
.Delete
On Error GoTo var2
If scr.Count = 0 Then GoTo son
.Add Type:=xlValidateList, Formula1:=Application.Transpose(Join(scr.Keys, ","))
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = False
.ShowError = False
GoTo son
var2:
If Target.Offset(0, -1).Value = "" Then GoTo son
.Add Type:=xlValidateList, Formula1:=Target.Offset(0, -1).Value
End With
End If
'--------------------------C sütununa göre------------------------------------------
If Not Intersect([C:C], Target) Is Nothing Then
For i = 1 To Cells(Rows.Count, 1).End(3).Row
If Target.Offset(0, -2).Value & "|" & Target.Offset(0, -1).Value = _
Cells(i, 1).Value & "|" & Cells(i, 2).Value Then
If Cells(i, 3).Value <> "" Then
scr(Cells(i, 3).Value) = scr(Cells(i, 3).Value)
End If
End If
Next
With Selection.Validation
.Delete
On Error GoTo var3
If scr.Count = 0 Then GoTo son
.Add Type:=xlValidateList, Formula1:=Application.Transpose(Join(scr.Keys, ","))
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = False
.ShowError = False
GoTo son
var3:
If Target.Offset(0, -1).Value = "" Then GoTo son
.Add Type:=xlValidateList, Formula1:=Target.Offset(0, -1).Value
End With
End If
son:
Set scr = Nothing
End Sub