Dynamic Depending Lists in VBA - vba

Question

I have found that code (on: http://www.siddharthrout.com/2011/07/29/excel-data-validationcreate-dynamic-dependent-lists-vba/) really useful:
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
That code works but when I try to put the DV list to another sheet and change the cells to write on, it doesn't work correctly...
When I select the option what I want to the list, the selected option is not written on the cell.
So the program runs without any problem but the result, it's not what i want.
The rearranged code is:
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 = Sheet2.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 = 2 To LastRow
If Len(Trim(Sheet2.Range("A" & i).Value)) <> 0 Then
On Error Resume Next
MyCol.Add CStr(Sheet2.Range("A" & i).Value), CStr(Sheet2.Range("A" & i).Value)
On Error GoTo 0
End If
Next i
' Create a list for the Data Validation List
For n = 1 To MyCol.Count
Templist = Templist & "," & MyCol(n)
Next
Templist = Mid(Templist, 2)
Range("A2").ClearContents: Range("A2").Validation.Delete
' Create the Data Validation List
If Len(Trim(Templist)) <> 0 Then
With Range("A2").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 A2
ElseIf Not Intersect(Target, Range("A2")) Is Nothing Then
SearchString = Range("A2").Value
Templist = FindRange(Sheet2.Range("A2:A" & LastRow), SearchString)
Range("B2").ClearContents: Range("B2").Validation.Delete
If Len(Trim(Templist)) <> 0 Then
' Create the DV List
With Range("B2").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
Is there somebody who has any idea if I have to change something more? Is there something tricky that I'm missing?