Hello

I have a spreadsheet with A column of a list of names and another column of projects associated with those names in a random order. The code I have makes me able to select a unique name in a dropdown box and then select a project according to that name in another dropdown box. I want to have an entire column of dropdown boxes where this can be done however the code only makes it work in the first row, [B9 and D9]. I would like the dropdown lists to go all the way down to [B1000 and D1000] if possible.

here is the code


Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long, LastRow As Long, n As Long
    Dim MyCol As Collection
    Dim SearchString As String, TempList As String
 
    Application.EnableEvents = False
 
    On Error GoTo Whoa
 
    '~~> Find LastRow in Col X
    LastRow = Range("X" & Rows.Count).End(xlUp).Row
 
    If Not Intersect(Target, Columns(1)) Is Nothing Then
        Set MyCol = New Collection
 
        '~~> Get the data from Col X into a collection
        For i = 9 To LastRow
            If Len(Trim(Range("X" & i).Value)) <> 0 Then
                On Error Resume Next
                MyCol.Add CStr(Range("X" & i).Value), CStr(Range("X" & i).Value)
                On Error GoTo 0
            End If
        Next i
 
        '~~> Create a list for the DV List
        For n = 1 To MyCol.Count
            TempList = TempList & "," & MyCol(n)
        Next
 
        TempList = Mid(TempList, 2)
 
        Range("B9").ClearContents: Range("B9").Validation.Delete

        '~~> Create the DV List
        If Len(Trim(TempList)) <> 0 Then
            With Range("B9").Validation
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:=TempList
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
        End If
    '~~> Capturing change in cell B9
    ElseIf Not Intersect(Target, Range("B9")) Is Nothing Then
        SearchString = Range("B9").Value
 
        TempList = FindRange(Range("X1:X" & LastRow), SearchString)
 
        Range("D9").ClearContents: Range("D9").Validation.Delete
 
        If Len(Trim(TempList)) <> 0 Then
            '~~> Create the DV List
            With Range("D9").Validation
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:=TempList
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
        End If
    End If
 
LetsContinue:
    Application.EnableEvents = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub
 
'~~> Function required to find the list from Col B
Function FindRange(FirstRange As Range, StrSearch As String) As String
    Dim aCell As Range, bCell As Range, oRange As Range
    Dim ExitLoop As Boolean
    Dim strTemp As String
 
    Set aCell = FirstRange.Find(what:=StrSearch, LookIn:=xlValues, _
    lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
 
    ExitLoop = False
 
    If Not aCell Is Nothing Then
        Set bCell = aCell
        strTemp = strTemp & "," & aCell.Offset(, 1).Value
        Do While ExitLoop = False
            Set aCell = FirstRange.FindNext(After:=aCell)
 
            If Not aCell Is Nothing Then
                If aCell.Address = bCell.Address Then Exit Do
                strTemp = strTemp & "," & aCell.Offset(, 1).Value
            Else
                ExitLoop = True
            End If
        Loop
        FindRange = Mid(strTemp, 2)
    End If
End Function

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Target = "X"


End Sub
The list of names is in column X and list of Projects is in column Y.
Can I amend this code to make that possible?