动态取决于VBA中的列表

Question

我发现代码（on：http://www.siddharthrout.com/2011/07/29/excel-data-validationcreate-dynamic-dependent-lists-vba/）非常有用：

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

该代码有效但当我尝试将DV列表放到另一张表并更改要写入的单元格时，它无法正常工作...

当我选择我想要的选项时，所选的选项不会写在单元格上。

所以程序运行没有任何问题，但结果，这不是我想要的。

重新排列的代码是：

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

是否有人知道我是否需要更改一些内容？我有什么特别的诡计吗？