如何在vba中获取excel下拉列表源

Question

Im使用VBA代码创建多个选择下拉列表。该代码将使目标单元格中的每个下拉列表变成多重选择列表，函数为：

如果target.specialcells（xlCellTypeAllValidation）为Nothing,则转到exitsub

目标单元格中下拉列表的来源是=间接(b14)，b14是另一个下拉列表（单选）。现在，如果b14的值将变成list1，我想让目标的单元格列表变成多个选择列表。在任何其他情况下，我希望它工作在正常的excel方式。我尝试用precaphe(target.validation.formula1)=“=list1”然后evalue(target.validation.formula1)来precaphy列表源，但是我得到了evalue(target.validation.formula1)的不匹配错误。我怎么做？

Answer 1

首先，使用worksheet_change事件意味着每个工作表更改都将运行您的代码，因此target可以是任何范围，而不仅仅是B14。您可以对任何单元格使用target.validation.formula1属性的假设是错误的，因为没有验证的单元格将不能使用此属性。

其次，你正在这样做：

If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then GoTo Exitsub

我相信您假设这是指target范围内的单元格，但实际上它指的是整个工作表中所有经过验证的单元格。尝试下面的代码来澄清：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngValidation As Range
    
    Set rngValidation = Target.SpecialCells(xlCellTypeAllValidation)

    Debug.Print Target.Address
    If Not rngValidation Is Nothing Then Debug.Print rngValidation.Address
End Sub

If Evaluate(Target.Validation.Formula1) = "=list1"

最后，如果我读了这个问题，我明白您希望根据B14中的值更改单元格D14中的列表，但您一直将目标引用为D14。如果B14被更改，那么B14是目标，而不是D14。如果更改D14，D14只能是目标。这就是事件的运作方式。

由于我不清楚您想要什么，我假设两种情况：

1. 单元格B14已更改，您要更新D14
2. 选中单元格D14，您希望在单击下拉列表之前更新列表

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    
    Dim rngValidation As Range
    Dim rngValidTarget As Range
    Dim rngCell As Range
    Dim rngArea As Range

    Set rngValidation = Target.Worksheet.Cells.SpecialCells(xlCellTypeAllValidation)
    Set rngValidTarget = Intersect(Target, rngValidation)
    If rngValidTarget Is Nothing Then GoTo ExitSub

    'validTarget could still be a multi-cell range
    On Error Resume Next
    For Each rngArea In rngValidTarget.Areas
        For Each rngCell In rngArea
            If rngCell.Validation.Type = xlValidateList Then
                If rngCell.Validation.Formula1 = "=List1" Then
                    Debug.Print rngCell.Address & " - Validation: " & rngCell.Validation.Formula1
                    'Do whatever logic you need to update other cells linking to this one
                    '
                    '
                    '
                End If
            End If
        Next rngCell
    Next rngArea
    On Error GoTo 0
ExitSub:
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.EnableEvents = False

    Dim rngValidation As Range
    Dim rngValidTarget As Range
    Dim rngCell As Range
    Dim rngArea As Range
    Dim rngList As Range
    Dim listFound As Boolean

    Set rngValidation = Target.Worksheet.Cells.SpecialCells(xlCellTypeAllValidation)
    Set rngValidTarget = Intersect(Target, rngValidation)
    If rngValidTarget Is Nothing Then GoTo ExitSub

    'validTarget could still be a multi-cell range
    On Error Resume Next
    For Each rngArea In rngValidTarget.Areas
        For Each rngCell In rngArea
            If rngCell.Validation.Type = xlValidateList Then
                Set rngList = Nothing
                Set rngList = Evaluate(rngCell.Validation.Formula1)
                listFound = False
                If Not rngList Is Nothing Then
                    listFound = (rngList.Name.Name = "List1")
                End If
                    
                If listFound Then
                    Debug.Print rngCell.Address & " - list found"
                    'Do whatever logic you need to update rngCell
                    '
                    '
                Else
                    Debug.Print rngCell.Address & " - list not found"
                    'Do whatever logic you need to update rngCell
                    '
                    '
                End If
            End If
        Next rngCell
    Next rngArea
    On Error GoTo 0
ExitSub:
    Application.EnableEvents = True
End Sub

可以使用以下代码翻译公式：

Private Function TranslateFormulaToUS(ByVal formulaText As String) As String
    On Error Resume Next
    With GetBlankEditableCell
        .Formula2Local = formulaText
        TranslateFormulaToUS = .Formula
        .Formula = vbNullString
    End With
    On Error GoTo 0
End Function

Private Function GetBlankEditableCell() As Range
    Dim wSheet As Worksheet
    Static blankCell As Range
    '
    'Re-use, if still blank
    If Not blankCell Is Nothing Then
        If IsEmpty(blankCell.Value2) Then
            Set GetBlankEditableCell = blankCell
            Exit Function
        End If
    End If
    '
    'Find a Blank cell
    For Each wSheet In ThisWorkbook.Worksheets
        Set blankCell = GetEditableBlankCellFromSheet(wSheet)
        If Not blankCell Is Nothing Then Exit For
    Next wSheet
    Set GetBlankEditableCell = blankCell
End Function

Private Function GetEditableBlankCellFromSheet(wSheet As Worksheet) As Range
    Dim rngBlanks As Range
    Dim rngCell As Range
    '
    On Error Resume Next
    Set rngBlanks = wSheet.UsedRange.SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    If rngBlanks Is Nothing Then Set rngBlanks = wSheet.Cells(1, 1)
    '
    'Check if Worksheet is Macro Protected
    If (wSheet.ProtectContents Or wSheet.ProtectDrawingObjects _
    Or wSheet.ProtectScenarios) And Not wSheet.ProtectionMode _
    Then
        For Each rngCell In rngBlanks
            If Not rngCell.Locked Is Nothing Then
                Set GetEditableBlankCellFromSheet = rngCell
                Exit Function
            End If
        Next rngCell
    Else
        Set GetEditableBlankCellFromSheet = rngBlanks.Cells(1, 1)
    End If
End Function

现在您可以替换如下内容：

Set rngList = Evaluate(rngCell.Validation.Formula1)

与：

Set rngList = Evaluate(TranslateFormulaToUS(rngCell.Validation.Formula1))

1. 选择列D中具有验证的第一个单元格
2. 创建一个本地命名范围，并添加公式=interfried(sheet1！$b8)（或者您所在的任何行--即B和D列中第一行，它都具有验证--我这里有8）。注意！不要使用绝对地址（即用=indirect(sheet1！$B$8))锁定行，因为我们希望命名的范围适用于整个D列

现在，让我们将新的命名范围链接到验证：

1. 选择列D中所有进行验证的单元格
2. 链接到您刚刚创建的命名范围

您也不再需要评估：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.EnableEvents = False

    Dim rngValidation As Range
    Dim rngValidTarget As Range
    Dim rngCell As Range
    Dim rngArea As Range
    Dim rngList As Range
    Dim listFound As Boolean
    Dim formulaText As String
    Dim nameList As Name

    Set rngValidation = Target.Worksheet.Cells.SpecialCells(xlCellTypeAllValidation)
    Set rngValidTarget = Intersect(Target, rngValidation)
    If rngValidTarget Is Nothing Then GoTo ExitSub

    'validTarget could still be a multi-cell range
    On Error Resume Next
    For Each rngArea In rngValidTarget.Areas
        For Each rngCell In rngArea
            If rngCell.Validation.Type = xlValidateList Then
                Set rngList = Nothing
                formulaText = rngCell.Validation.Formula1
                If Left$(formulaText, 1) = "=" Then
                    formulaText = Right$(formulaText, Len(formulaText) - 1)
                End If
                Set nameList = Nothing
                Set nameList = rngCell.Worksheet.Names(formulaText)
                Set rngList = nameList.RefersToRange
                
                listFound = False
                If Not rngList Is Nothing Then
                    listFound = (rngList.Name.Name = "'" & rngList.Worksheet.Name & "'!" & "List1") _
                        Or (rngList.Name.Name = rngList.Worksheet.Name & "!" & "List1")
                End If
                    
                If listFound Then
                    Debug.Print rngCell.Address & " - list found"
                    'Do whatever logic you need to update rngCell
                    '
                    '
                Else
                    Debug.Print rngCell.Address & " - list not found"
                    'Do whatever logic you need to update rngCell
                    '
                    '
                End If
            End If
        Next rngCell
    Next rngArea
    On Error GoTo 0
ExitSub:
    Application.EnableEvents = True
End Sub