Question

I would like to create an excel sheet where data shall be entered into Row-* – Column-A.

Upon entering data into Row-N::Column-A, I would like to associate the entered data with an entry chosen from a drop down list available at Column-B.

Now, each item in the list of Column-B has infact a dedicated list. If I selected Item-X in Column-B, it should be possible for me to select in Column-C an item from a list dedicated to Item-X.

How is this to be done?

Answer 1

The below code will help you create dependent lists just by simply pasting data in the Source Columns. For the sake of simplicity we will copy and paste the above list in Column A and Column B of an Excel Sheet, say Sheet1. However before we do that, we have to paste the below code in the Sheet Code Area. The sheet code area can be accessed by pressing Alt+F11 from the main worksheet.

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 A
    LastRow = Range("A" & Rows.Count).End(xlUp).Row

    If Not Intersect(Target, Columns(1)) Is Nothing Then
        Set MyCol = New Collection

        '~~> Get the data from Col A into a collection
        For i = 1 To LastRow
            If Len(Trim(Range("A" & i).Value)) <> 0 Then
                On Error Resume Next
                MyCol.Add CStr(Range("A" & i).Value), CStr(Range("A" & 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("D1").ClearContents: Range("D1").Validation.Delete

        '~~> Create the DV List
        If Len(Trim(TempList)) <> 0 Then
            With Range("D1").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 D1
    ElseIf Not Intersect(Target, Range("D1")) Is Nothing Then
        SearchString = Range("D1").Value

        TempList = FindRange(Range("A1:A" & LastRow), SearchString)

        Range("E1").ClearContents: Range("E1").Validation.Delete

        If Len(Trim(TempList)) <> 0 Then
            '~~> Create the DV List
            With Range("E1").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

You can get more details about the above here.