文章/答案/技术大牛

发布

社区首页 >问答首页 >如何在vba中获取excel下拉列表源

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

Stack Overflow用户

提问于 2020-10-09 13:08:27

回答 3查看 6.4K关注 0票数 2

我在使用VBA code to create multiple selection drop down list。代码将使目标单元格中的每个下拉列表成为具有以下功能的多个选择列表：

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

目标单元格中下拉列表的来源是=indirect(b14)，而b14是另一个下拉列表(单个选择)。现在，如果b14的值将变为list1，则Id希望使我的目标单元格列表成为多个选择列表。在任何其他情况下，我希望它以正常的excel方式工作。我尝试过用if Evaluate(Target.Validation.Formula1) = "=list1" then预置列表源，但是Evaluate(Target.Validation.Formula1)的错误不匹配。我该怎么做呢？

编辑:我的工作表中有一些截图示例，不要误解它的结构。

A1:A5命名范围list1，B1:B5命名范围list2，B14数据验证列表= list 1

D14数据验证列表与=间接(B14)公式

vba

excel

回答 3

Stack Overflow用户

回答已采纳

发布于 2020-10-20 10:49:56

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

第二，你这样做：

如果

If Target.SpecialCells(xlCellTypeAllValidation)为零，则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

您可以在直接窗口中看到，无论您正在编辑哪个单元格，rngValidation始终指向工作表中的所有验证单元格。

第三，你这样做：

如果

(Target.Validation.Formula1)=“=list1 1”，则为

这将无法工作，因为Evaluate("=Indirect(B14)")只是返回一个数组，而不是您假设的字符串。

最后，如果我阅读了这个问题，我知道您希望根据D14中的值更改单元格B14中的列表，但是您仍然将Target称为D14。如果B14被更改，那么B14就是Target，而不是D14。只有当您更改D14时，Target才能成为D14。事情就是这样进行的。

因为我不清楚你想要什么，所以我假设了两种情况：

Cell B14已更改，您希望更新D14
Cell D14，您希望在单击下拉

之前更新列表

场景1 -单元格B14已更改，您希望更新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

选择了场景2 - Cell D14 (或等效的)，您希望在单击下拉列表之前更新列表。

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

编辑1

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

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))

编辑2

如果您想避免编辑1中提到的翻译，那么您可以使用注释中提到的动态相对命名范围。

让我们从当前的布局开始(我想我做对了)：

命名范围List1是一个本地范围范围：

命名范围List2也是一个本地范围范围：

B列(行可能因工作表而异)将数据验证设置为List1：

让我们创建第三个命名范围，名为RemoteDV：

在D列中选择具有validation

Create本地命名范围的

第一个单元格，并添加公式=INDIRECT(Sheet1!$B8) (或您所在的任何行--即B列和D列中具有验证的第一行--这里有8行)。注意到！不要使用绝对地址(即用=INDIRECT(Sheet1!$B$8)锁定行)，因为我们希望命名的范围可用于整个D列

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

选择D列中具有validation

Link的所有单元格到您刚刚创建的

的命名范围

最终的结果是，您不必再翻译公式了。

您也不再需要评估了：

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

票数 3

Stack Overflow用户

发布于 2020-10-09 14:42:39

编辑:下面是一个简单的代码块，应该做你需要的。首先，我在单元格A1中创建了一个数据验证下拉列表。接下来，我创建了一个名为List1的列表，并将其指向一系列的值。接下来，我将数据验证的列表->公式设置为=INDIRECT(B14)。最后，我在单元格List1中输入了文本B14。

我运行了下面的测试脚本来查看输出结果。

Sub Test()
    Dim rangeWithDropdown As Range
    
    Set rangeWithDropdown = Sheets("Sheet1").Range("A1")
    
    Debug.Print rangeWithDropdown.Validation.Formula1
    Debug.Print Evaluate(rangeWithDropdown.Validation.Formula1).Name
    Debug.Print Evaluate(rangeWithDropdown.Validation.Formula1).Name = ThisWorkbook.Names("List1").Value
End Sub

我的产出如下：

=INDIRECT(B14)
=Sheet1!$D$1:$D$4
True

单独请求公式时，它返回=INDIRECT(B14)。在计算公式并返回名称时，它将返回我创建的范围。最后，当针对命名范围测试等式时，它返回true。

我的理解正确吗？您能否尝试在工作簿上运行这段代码(更新数据验证单元引用)，然后告诉我哪一行会抛出错误？结束编辑

您的代码不能工作的原因是Evaluate(=indirect(B14))不返回范围的名称，而是返回范围的地址。因此，如果List1引用范围(“A1:A10”)，那么Evaluate函数将返回Sheet1!Range("A1:A10")。当您尝试将字符串("list1")与范围进行比较时，会得到类型不匹配错误。

一种选择是将返回的范围与预期的"List1“范围进行比较。例如，以下代码可能有效：If evaluate(activecell.validation.formula1).name = activeworkbook.Names("List1").Value

票数 2

Stack Overflow用户

发布于 2020-10-24 10:11:19

我看到其他人做了很多工作。我不想“偷”他们的解决方案，所以我没有完全阅读它们。我希望我的贡献不会越位。我谦卑地开始贴出我的答案。

如果在具有第一个下拉列表(B列)的列中，上述下拉列表已经存在，那么我们的"List1“结果将是一个可能的值。此解决方案检查该值是否为"List1“，并以密码方式创建第二个下拉列表：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    'Declarations.
    Dim DblStartingRow As Double
    Dim DblEndingRow As Double
    Dim RngFirstDropDownList As Range
    Dim RngSecondDropDownList As Range
    Dim RngRange01
    Dim StrTrigger As String
    
    ''''''''''''''''''''''''''''
    'VARIABLES SETTINGS - Start'
    ''''''''''''''''''''''''''''
    
    'StrTrigger will be the value that if found in the first drop down _
    list will trigger the creation of the second drop down list.
    StrTrigger = "List1"
    
    'DblStartingRow is the first row that will possibly contain one of _
    our drop down list.
    DblStartingRow = 14
    
    'DblStartingRow is the last row that will possibly contain one of _
    our drop down list.
    DblEndingRow = Rows.Count
    
    'Setting RngFirstDropDownList and RngSecondDropDownList to match _
    the entire columns where our lists of drop-down lists will be found.
    Set RngFirstDropDownList = Range("B:B")
    Set RngSecondDropDownList = Range("D:D")
    
    ''''''''''''''''''''''''''
    'VARIABLES SETTINGS - End'
    ''''''''''''''''''''''''''
    
    'Resetting RngSecondDropDownList to cover only the rows we need to _
    cover according to DblStartingRow and DblEndingRow
    Set RngSecondDropDownList = RngSecondDropDownList.Resize(DblEndingRow - DblStartingRow + 1, 1).Offset(DblStartingRow - 1, 0)
    
    'Checking if Target intersects with RngSecondDropDownList. If there _
    is no intersection, the subroutine is terminated. Otherwise RngRange01 _
    is set as such intersection.
    On Error Resume Next
    Set RngRange01 = Intersect(Target, RngSecondDropDownList)
    On Error GoTo 0
    If RngRange01 Is Nothing Then Exit Sub
    
    'Covering each cell in RngRange01
    For Each RngSecondDropDownList In RngRange01
        
        'Setting RngFirstDropDownList as the cell in the column of first _
        drop-down lists at the same row of our (possible) second drop-down _
        list.
        Set RngFirstDropDownList = Cells(RngSecondDropDownList.Row, RngFirstDropDownList.Column)
        
        'Focusing RngSecondDropDownList.
        With RngSecondDropDownList.Validation
            
            'Removing validation.
            .Delete
            
            'Checking if RngFirstDropDownList contains StrTrigger.
            If RngFirstDropDownList.Formula = StrTrigger Then
                
                'Adding the dropdown list.
                .Add Type:=xlValidateList, _
                     AlertStyle:=xlValidAlertStop, _
                     Operator:=xlBetween, _
                     Formula1:="=INDIRECT(" & RngFirstDropDownList.Address & ")"
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End If
            
        End With
    Next
    
End Sub

如果要放在工作表的模块中，每次选择被更改时，它都会激活。如果选择与第二个下拉列表的范围相交，它将为所述交集中的每个单元插入这样的下拉列表。适用于单个和多个单元格的选择。我已经将所有可能的参数设置为一个变量，该变量可以在声明后的子程序的第一部分中进行更改。这应该符合问题的要求。

然后，如果问题希望只在以下情况下创建第二个下拉列表：

Validation.Formula1

在适当的单元格中有第一个下拉列表，
表示，第一个下拉列表具有特定的
。

那么我建议的代码是：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    'Declarations.
    Dim DblStartingRow As Double
    Dim DblEndingRow As Double
    Dim RngFirstDropDownList As Range
    Dim RngSecondDropDownList As Range
    Dim RngRange01
    Dim StrTrigger As String
    Dim StrValidation As String
    
    ''''''''''''''''''''''''''''
    'VARIABLES SETTINGS - Start'
    ''''''''''''''''''''''''''''
    
    'StrTrigger will be the formula that if found in Validation.Formula1 _
    of the first drop-down list will trigger the creation of the second _
    drop down list.
    StrTrigger = "=List1"
    
    'DblStartingRow is the first row that will possibly contain one of _
    our drop down list.
    DblStartingRow = 14
    
    'DblStartingRow is the last row that will possibly contain one of _
    our drop down list.
    DblEndingRow = Rows.Count
    
    'Setting RngFirstDropDownList and RngSecondDropDownList to match _
    the entire columns where our lists of drop-down lists will be found.
    Set RngFirstDropDownList = Range("B:B")
    Set RngSecondDropDownList = Range("D:D")
    
    ''''''''''''''''''''''''''
    'VARIABLES SETTINGS - End'
    ''''''''''''''''''''''''''
    
    'Resetting RngSecondDropDownList to cover only the rows we need to _
    cover according to DblStartingRow and DblEndingRow
    Set RngSecondDropDownList = RngSecondDropDownList.Resize(DblEndingRow - DblStartingRow + 1, 1).Offset(DblStartingRow - 1, 0)
    
    'Checking if Target intersects with RngSecondDropDownList. If there _
    is no intersection, the subroutine is terminated. Otherwise RngRange01 _
    is set as such intersection.
    On Error Resume Next
    Set RngRange01 = Intersect(Target, RngSecondDropDownList)
    On Error GoTo 0
    If RngRange01 Is Nothing Then Exit Sub
    
    'Covering each cell in RngRange01
    For Each RngSecondDropDownList In RngRange01
        
        'Setting RngFirstDropDownList as the cell in the column of first _
        drop-down lists at the same row of our (possible) second drop-down _
        list.
        Set RngFirstDropDownList = Cells(RngSecondDropDownList.Row, RngFirstDropDownList.Column)
        
        'Focusing RngSecondDropDownList.
        With RngSecondDropDownList.Validation
            
            'Removing validation.
            .Delete
            
            'Checking if RngFirstDropDownList contains a drop-down list _
            based on StrTrigger.
            On Error GoTo CP_No_Drop_down_List
            If RngFirstDropDownList.Validation.Formula1 = StrTrigger Then
                
                'Adding the dropdown list.
                .Add Type:=xlValidateList, _
                     AlertStyle:=xlValidAlertStop, _
                     Operator:=xlBetween, _
                     Formula1:="=INDIRECT(" & RngFirstDropDownList.Address & ")"
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End If
CP_No_Drop_down_List:
            On Error GoTo 0
            
        End With
    Next
    
End Sub

此代码与前面的代码相似，但实际上它将检查是否存在基于指定的Validation.Formula1的第一个下拉列表。请注意，如果希望创建第二个下拉列表，而不是根据第一个下拉列表值的实际间接引用创建第二个下拉列表，则可以替换行。

Formula1:="=INDIRECT(" & RngFirstDropDownList.Address & ")"

带着线

Formula1:=StrTrigger

票数 1

页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持

原文链接：

https://stackoverflow.com/questions/64280750

复制

相似问题

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

回答 3

Stack Overflow用户

Stack Overflow用户

Stack Overflow用户

社区

活动

圈层

关于

腾讯云开发者

热门产品

热门推荐

更多推荐

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

回答 3

Stack Overflow用户

Stack Overflow用户

Stack Overflow用户

社区

活动

圈层

关于

腾讯云开发者

热门产品

热门推荐

更多推荐

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