Question

我想做的是循环数据验证，当我找到一个匹配项时，从数据验证中选择选项。下面是我的代码：

Option Explicit

Sub Insert()

    Dim LastRow As Long, i As Long
    Dim str As String
    Dim rng As Range, Opt As Range

    With ThisWorkbook.Worksheets("Sheet1")

        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        For i = 1 To LastRow

            str = .Range("A" & i).Value

            Set rng = Evaluate(.Range("B" & i).Validation.Formula1)

            For Each Opt In rng

                If Opt.Value = str Then
                    Opt.Select
                End If

            Next

        Next i

    End With

End Sub

我得到一个：

运行时错误'424'

在线：Set rng = Evaluate(.Range("B" & i).Validation.Formula1)

键入：?.Range("B" & i).Validation.Formula1在立即窗口上从数据验证列表中获取所有值。

任何帮助将不胜感激！

答案

我要做的是以下事情：

Option Explicit

Sub Insert()

    Dim LastRow As Long, i As Long, y As Long
    Dim str As String
    Dim arr As Variant, element As Variant

    With ThisWorkbook.Worksheets("Sheet1")

        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        For i = 1 To LastRow

            str = .Range("A" & i).Value

            arr = Split(.Range("B" & i).Validation.Formula1, ",")

            For y = LBound(arr, 1) To UBound(arr, 1)

                If InStr(1, arr(y), str) > 0 Then
                    .Range("B" & i) = arr(y)
                    Exit For
                Else
                    .Range("B" & i).ClearContents
                End If

            Next y

        Next i

    End With

End Sub

Answer 1

.Range("B" & i).Validation.Formula1返回一个String值。 Error 424由关键字Set引起。如果键入了列表，则需要将其拆分为一个数组并遍历这些元素。

Option Explicit

Sub Insert()

    Dim LastRow As Long, i As Long
    Dim str As String
    Dim dvArr
    Dim opt As Long

    With Worksheets("Report 11")

        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        For i = 1 To LastRow

            str = .Range("A" & i).Value

            dvArr = Split(.Range("B" & i).Validation.Formula1, ",")

            For opt = LBound(dvArr) To UBound(dvArr)
                If dvArr(opt) = str Then
                    .Range("B" & i) = dvArr(opt)
                End If

            Next

        Next i

    End With

End Sub

如果未键入列表，则可以替换返回字符串值中的=以引用范围。

Option Explicit

Sub Insert()

    Dim LastRow As Long, i As Long
    Dim str As String
    Dim rng As Range, Opt As Range

    With ThisWorkbook.Worksheets("Sheet1")

        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        For i = 1 To LastRow

            str = .Range("A" & i).Value

            set rng = .Range(Replace(.Range("B" & i).Validation.Formula1,"=",""))

            For Each Opt In rng

                If Opt.Value = str Then
                    .Range("B" & i) = Opt.Value
                End If

            Next

        Next i

    End With

End Sub

Answer 2

您的代码仅适用于已设置数据验证且其中Formula1包含范围的单元格。数据验证具有属性Type，该属性告诉您所使用的验证类型。类型列表可在https://docs.microsoft.com/en-us/office/vba/api/excel.xldvtype

中找到

对于您的情况（值列表），该类型为3。因此，在分配之前，应检查验证是否具有类型3。不幸的是，如果未对单元格设置任何验证，并且您检查了验证类型，则会收到运行时错误（1004）。

这可以用类似的代码处理

On Error Resume Next
Dim hasValidation  As Boolean
hasValidation = (rng.Validation.Type = 3)
On Error GoTo 0
If hasValidation Then
    ....

我承认这并不比写作好

 On Error Resume Next
 set rng = Nothing
 set rng = Evaluate(.Range("B" & i).Validation.Formula1)

 On Error Goto 0
 if not rng is Nothing then
    ....

另一种选择是仅在具有数据验证的单元格上循环

dim cell as range
For Each cell In .Range("B:B").EntireRow.SpecialCells(xlCellTypeAllValidation)
    if cell.Validation.type = 3 Then
        set rng = Evaluate(cell.Validation.Formula1)
        ....

当Evaluate包含一个Formula1时，使用Range的技巧应该可以起作用，不需要修改字符串（删除=或类似的东西）。

最后一句话：在原始代码中，您只对找到的值执行了Select，但是继续执行循环，该循环检查所有具有验证的单元格。如果您有多个带有数据验证的单元，则必须下定决心。

循环数据验证列表

2 个答案: