Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Row < 2 Then Exit Sub
    
    Dim yy As Long
    yy = Cells(Rows.Count, 1).End(xlUp).Row
    If yy < 3 Then Exit Sub
    
    Dim arr As Variant
    arr = Cells(1, 1).Resize(yy, 4)
    
    Dim brr As Variant
    For yy = 3 To UBound(arr, 1)
        If IsEmpty(arr(yy, 2)) Then Exit For
        If IsEmpty(brr) Then
            ReDim brr(0 To 0)
        Else
            ReDim Preserve brr(0 To UBound(brr) + 1)
        End If
        brr(UBound(brr)) = arr(yy, 2)
    Next
    If Not IsEmpty(brr) Then
        With Cells(2, 6).Resize(1, ActiveSheet.UsedRange.Columns.Count - 5).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(brr, ",")
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = False
        End With
        brr = Empty
    End If
    
    If Target.Row > 5 Then Exit Sub
    
    For yy = 17 To UBound(arr, 1)
        If arr(yy, 1) = Cells(2, Target.Column).Value Then
            If IsEmpty(brr) Then
                ReDim brr(0 To 0)
            Else
                ReDim Preserve brr(0 To UBound(brr) + 1)
            End If
            brr(UBound(brr)) = arr(yy, 2)
        End If
    Next
    If Not IsEmpty(brr) Then
        With Cells(3, Target.Column)
            With .Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(brr, ",")
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = False
            End With
            If InStr(Join(brr, ","), .Value) = 0 Or .Value = "" Then
                Application.EnableEvents = False
                If UBound(brr) = LBound(brr) Then
                    .Value = brr(LBound(brr))
                Else
                    .Value = Empty
                End If
                Application.EnableEvents = True
            End If
        End With
        brr = Empty
    End If
    
    For yy = 17 To UBound(arr, 1)
        If arr(yy, 1) = Cells(2, Target.Column).Value Then
        If arr(yy, 2) = Cells(3, Target.Column).Value Then
            
            If IsEmpty(brr) Then
                ReDim brr(0 To 0)
            Else
                ReDim Preserve brr(0 To UBound(brr) + 1)
            End If
            brr(UBound(brr)) = arr(yy, 3)
        End If
        End If
    Next
    If Not IsEmpty(brr) Then
        With Cells(4, Target.Column)
            With .Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(brr, ",")
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = False
            End With
            If InStr(Join(brr, ","), .Value) = 0 Or .Value = "" Then
                Application.EnableEvents = False
                If UBound(brr) = LBound(brr) Then
                    .Value = brr(LBound(brr))
                Else
                    .Value = Empty
                End If
                Application.EnableEvents = True
            End If
        End With
        brr = Empty
    End If
        
    For yy = 17 To UBound(arr, 1)
        If arr(yy, 1) = Cells(2, Target.Column).Value Then
        If arr(yy, 2) = Cells(3, Target.Column).Value Then
        If arr(yy, 3) = Cells(4, Target.Column).Value Then
            
            If IsEmpty(brr) Then
                ReDim brr(0 To 0)
            Else
                ReDim Preserve brr(0 To UBound(brr) + 1)
            End If
            brr(UBound(brr)) = arr(yy, 4)
        End If
        End If
        End If
    Next
    If Not IsEmpty(brr) Then
        With Cells(5, Target.Column)
            With .Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(brr, ",")
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = False
            End With
            If InStr(Join(brr, ","), .Value) = 0 Or .Value = "" Then
                Application.EnableEvents = False
                If UBound(brr) = LBound(brr) Then
                    .Value = brr(LBound(brr))
                Else
                    .Value = Empty
                End If
                Application.EnableEvents = True
            End If
        End With
        brr = Empty
    End If
End Sub