Best way to write repeated code in VBA Dependent List of Values - excel

Question

I have total 15 columns with Data Validation Drop-down.
Drop-down for Column 2 to 15 are dependent on value selected in Column 1.
Drop-down for Column 3 is dependent on value selected in Column 2. If Column 3 value is selected directly then value for Column 2 must be populated in the excel cell of column 2.
Drop-down for Column 5 and 6 are dependent on Column 4 and so on.
Please find the code below for Column 2 and 3 dependent on Column 1 which is very lengthy. Is there any best/dynamic way to write this code to make sure all of my requirement is satisfied in VBA?
Dim rowNum As Long
Dim ListBoxRow As Long
Dim filterRowNum As Long
Dim col2 As String
Dim col3 As String
rowNum = 2
filterRowNum = 2
col2 = ""
col3 = ""
Do Until Worksheets("Col1Col2Col3Sheet").Cells(rowNum, 1).Value = ""
If InStr(1, Worksheets("Col1Col2Col3Sheet").Cells(rowNum, 1).Value, activeCellValue, vbTextCompare) Then
If filterRowNum = 2 Then
col2 = col2 & Worksheets("Col1Col2Col3Sheet").Cells(rowNum, 2).Value
col3 = col3 & Worksheets("Col1Col2Col3Sheet").Cells(rowNum, 5).Value
Else
If InStr(col2, Worksheets("Col1Col2Col3Sheet").Cells(rowNum, 2).Value) = 0 Then
col2 = col2 & "," & Worksheets("Col1Col2Col3Sheet").Cells(rowNum, 2).Value
End If
If InStr(col3, Worksheets("Col1Col2Col3Sheet").Cells(rowNum, 5).Value) = 0 Then
col3 = col3 & "," & Worksheets("Col1Col2Col3Sheet").Cells(rowNum, 5).Value
End If
End If
filterRowNum = filterRowNum + 1
End If
rowNum = rowNum + 1
Loop
With Worksheets("CustomSpreadsheet").Range("F" & ActiveCellRow).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=col2
.IgnoreBlank = True
.InCellDropdown = True
.ShowError = True
End With
With Worksheets("CustomSpreadsheet").Range("G" & ActiveCellRow).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=col3
.IgnoreBlank = True
.InCellDropdown = True
.ShowError = True
End With

Answer 1

Here's one way - abstract out all of the work to separate methods: one to give you a list of all unique matches, and the other to set up the validation:
'Set a cell validation list
'You might consider expanding this to also delete any previously-selected
' value if it's not in the list of values being added
Sub SetCellList(c As Range, lst As String)
With c.Validation
.Delete
If Len(lst) > 0 Then 'make sure there's something to add...
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=lst
.IgnoreBlank = True
.InCellDropdown = True
.ShowError = True
End If
End With
End Sub
'Return a comma-delimited list of all unique "sub-values"
'columnsToCheck: array of cell at the top(s) of the column(s) you want to scan for matches
'valuestoCheck: array of the value to look for in columnsToCheck
'returnColLetter: when a match is made, return all unique values from this column
Function Uniques(columnsToCheck, valuestoCheck, returnColLetter As String) As String
Dim arrA, arrB, rngCheck As Range, r As Long, i As Long, c As Range, n As Long, rng As Range
Dim dict As Object, bMatch As Boolean
Set dict = CreateObject("scripting.dictionary")
'translate array of column header cells to array of 2D arrays
'pick up values from return column
For i = LBound(columnsToCheck) To UBound(columnsToCheck)
Set c = columnsToCheck(i)
If i = LBound(columnsToCheck) Then
Set rng = c.Parent.Range(c, c.Parent.Cells(Rows.Count, c.Column).End(xlUp))
arrB = rng.EntireRow.Columns(returnColLetter).Value 'values to return
n = rng.Rows.Count '# of rows
Else
Set rng = c.Resize(n, 1) 'columns should be all the same size...
End If
columnsToCheck(i) = ToArray(rng)
Next i
'loop rowa to check and collect any matches
For r = 1 To n
bMatch = True
'loop columns to check
For i = LBound(columnsToCheck) To UBound(columnsToCheck)
If columnsToCheck(i)(r, 1) <> valuestoCheck(i) Then
bMatch = False
Exit For
End If
Next i
If bMatch Then dict(arrB(r, 1)) = True
Next r
Uniques = Join(dict.keys, ",")
End Function
'Safely get a 2D array from a range, even if the range is a single cell
Function ToArray(rng As Range)
Dim arr(1 To 1, 1 To 1)
If rng.Cells.Count = 1 Then
arr(1, 1) = rng.Value
ToArray = arr
Else
ToArray = rng.Value
End If
End Function
Example usage using a change event:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, c As Range, v
'this range depends only on the cell to the left
Set rng = Application.Intersect(Target, Me.Range("N2:N25"))
If Not rng Is Nothing Then
For Each c In rng.Cells
v = Trim(c.Value)
If Len(v) > 0 Then
'set list in next column over
SetCellList c.Offset(0, 1), _
Uniques(Array(lists.Cells(1, "A")), _
Array(v), "B")
End If
Next c
End If
'this range depends only on the two cells to the left
Set rng = Application.Intersect(Target, Me.Range("O2:O25"))
If Not rng Is Nothing Then
For Each c In rng.Cells
v = Trim(c.Value)
If Len(v) > 0 Then
'set list in next column over
SetCellList c.Offset(0, 1), _
Uniques(Array(lists.Cells(1, "A"), lists.Cells(1, "B")), _
Array(Trim(c.Offset(0, -1).Value), Trim(c.Value)), "C")
End If
Next c
End If
End Sub