Question

我的电子表格中的C列包含将由客户选择并经常更新的值。我希望列D能够动态应用从该列表中提取的数据验证。但是，它需要包含按字母顺序排列的唯一值。

我目前正在使用以下公式按字母顺序对隐藏列（BK）中的值进行排序。（注意：我发现这个网站表明它应该只显示唯一的值，但它没有）。

{=INDEX(List,MATCH(0,IF(MAX(NOT(COUNTIF($BK$15:BK15,List))*(COUNTIF(List,">"&List)+1))=(COUNTIF(List,">"&List)+1),0,1),0))}

要动态更新D列，我使用以下代码：

Dim NewRng As Range
Dim RefList As Range, c As Range, rngHeaders As Range, RefList2 As Range, msg

On Error GoTo ErrHandling


Set NewRng = Application.Intersect(Me.Range("D16:D601"), Target)
If Not NewRng Is Nothing Then

    Set rngHeaders = Range("A15:ZZ16").Find("Status List", After:=Range("E15"))
    Set RefList = Range(rngHeaders.Offset(1, 0).Address, rngHeaders.Offset(100, 0).Address)
    RefList.Copy
    RefList.Offset(0, 1).PasteSpecial xlPasteValues
    Set RefList2 = RefList.Offset(0, 1)


    Application.DisplayAlerts = False
    RefList2.RemoveDuplicates Columns:=1


    For Each c In NewRng
        c.Validation.Delete
        c.Validation.Add Type:=xlValidateList, _
                                 AlertStyle:=xlValidAlertStop, _
                                 Formula1:="=" & RefList2.Address

    Next c
End If
Application.DisplayAlerts = True
Application.EnableEvents = True

这似乎有效，除了每次点击D栏中的单元格时，它仍会抛出一个名为“删除重复项”的弹出框，其中显示两个选中的复选框 - “全选”和“列BL”。它还告诉我发现了多少重复项以及剩余多少个唯一值。

我不知道为什么displayalerts = false没有关闭它，但是每当有人点击D列时，肯定不会有这种火灾的选择。有没有人见过这个？（顺便说一句，我在Excel for Mac 2016上）。

Answer 1

我仍然没有找到抑制或自动接受弹出框的方法，这会导致更多问题，因为这意味着我选择的D列中的单元格不再被选中，所以我可以＆＃ 39; t从下拉列表中选择。 但是，我想知道是否有人有任何可能比我上述方法更简单的替代想法。

基本上我有两种不同的场景需要实现：

上面的场景，我需要从中提取唯一值列C进入D列的数据验证下拉列表。

我还需要根据当前处于列表格式的不是的其他页面上的值创建下拉列表。例如，在下面的代码中，我正在寻找当前在另一页面上的标题中的任何值（即，单元格被合并）。现在我是查找/复制/粘贴/验证，但这似乎很复杂。当然，它遇到与方案1相同的弹出问题。

Dim EvalRng As Range
Set ws = ThisWorkbook.Sheets("Evaluation Forms")
Dim EvalList As Range, EvalList2 As Range, EvalHeader As Range

On Error GoTo ErrHandling2

Set EvalRng = Application.Intersect(Me.Range("E16:E601"), Target)
Set EvalHeader = Range("A15:ZZ16").Find("Evaluation Forms List", 
After:=Range("E15"))

If Not EvalRng Is Nothing Then

For Each c In ws.Range("A15:A105")
    If c.MergeCells Then
        c.Copy
        EvalHeader.Offset(1, 0).PasteSpecial xlPasteValues
        Set EvalHeader = EvalHeader.Offset(1, 0)
    End If


Next c

'Set EvalList = Range(EvalHeaders.Offset(1, 0).Address, EvalHeaders.Offset(100, 0).Address)
Set EvalList = EvalHeader.Offset(1, 0).End(xlDown)

EvalList.Copy
EvalList.Offset(0, 1).PasteSpecial xlPasteValues
Set EvalList2 = EvalList.Offset(0, 1)


Application.DisplayAlerts = False
Application.EnableEvents = False
EvalList2.RemoveDuplicates Columns:=Array(1), header:=xlNo


For Each c In ActionRng
    c.Validation.Delete
    c.Validation.Add Type:=xlValidateList, _
                             AlertStyle:=xlValidAlertStop, _
                             Formula1:="=" & EvalList2.Address

Next c

结束如果

Answer 2

我找到了一种方法来使用RemoveDuplicates来实现所需的结果。感谢Jean-Francois Corbett和SJR提供了构建此解决方案的一些代码。见下文：

Public varUnique As Variant

Public ResultingStatus As Range
Public WhenAction As Range
Public EvalForm As Range



'Remove Case Sensitivity
  Option Compare Text

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Application.ScreenUpdating = False
Application.EnableEvents = False

'Prevents users from deleting columns that would mess up the header box
If Selection.Rows.Count = ActiveSheet.Rows.Count Then
    If Not Intersect(Target, Range("A:H")) Is Nothing Then

        Range("A1").Select
    End If

End If


Call StatusBars(Target)

Dim rngIn As Range
Dim varIn As Variant
Dim iInCol As Long
Dim iInRow As Long
Dim iUnique As Long
Dim nUnique As Long
Dim isUnique As Boolean
Dim i As Integer
Dim ActionRng As Range
Dim EvalRng As Range
Dim ActionList As Range, c As Range, rngHeaders As Range, ActionList2 As Range, msg
Dim ws As Worksheet


Set ResultingStatus = Range("A15:Z15").Find("Resulting Status")
Set WhenAction = Range("A15:Z15").Find("When can this action")
Set EvalForm = Range("A15:Z15").Find("Evaluation Form")


'When can action be taken list

    'On Error GoTo ErrHandling



Set ActionRng = Application.Intersect(Me.Range("D16:D601"), Target)
    If Not ActionRng Is Nothing Then
        Set rngIn = Range(ResultingStatus.Offset(1, 0).Address, ResultingStatus.Offset(1000, 0).End(xlUp).Address)
        varIn = rngIn.Value

        ReDim varUnique(1 To UBound(varIn))

        nUnique = 0
        For i = LBound(varIn) To UBound(varIn)
            isUnique = True
            For iUnique = 1 To nUnique
                If varIn(i, 1) = varUnique(iUnique) Then
                    isUnique = False
                    Exit For
                End If
            Next iUnique
            If isUnique = True Then
                nUnique = nUnique + 1
                varUnique(nUnique) = varIn(i, 1)
            End If
        Next i

        '// varUnique now contains only the unique values.
        '// Trim off the empty elements:
        ReDim Preserve varUnique(1 To nUnique)

        QuickSort varUnique, LBound(varUnique), UBound(varUnique)


        myvalidationStr = ""
        For Each x In varUnique
            myvalidationStr = myvalidationStr & x & ","
        Next x

        myvalidationStr = Left(myvalidationStr, Len(myvalidationStr) - 1)

            With ActionRng.Validation

                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:=myvalidationStr
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With

    End If


Here:
'Eval forms

Set ws = ThisWorkbook.Sheets("Evaluation Forms")
Dim EvalList As Range, EvalList2 As Range, EvalHeader As Range

On Error GoTo ErrHandling2
Set EvalRng = Application.Intersect(Me.Range("E16:E601"), Target)
Dim cUnique As Collection
Dim vNum As Variant
Set cUnique = New Collection

If Not EvalRng Is Nothing Then
    On Error Resume Next
    For Each c In ws.Range("A15:A105")
            If c.MergeCells Then
                cUnique.Add c.Value, CStr(c.Value)
            End If
    Next c

QuickSort2 cUnique, 1, cUnique.Count


        myvalidationStr = ""
        For Each x In cUnique
            myvalidationStr = myvalidationStr & x & ","
        Next x

        myvalidationStr = Left(myvalidationStr, Len(myvalidationStr) - 1)

            With EvalRng.Validation

                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:=myvalidationStr
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With

    End If





Here2:

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True

    Exit Sub

ErrHandling:
    If Err.Number <> 0 Then
        msg = "Error # " & Str(Err.Number) & " was generated by " & _
            Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
        Debug.Print msg, , "Error", Err.HelpFile, Err.HelpContext
    End If
    Resume Here

ErrHandling2:
    If Err.Number <> 0 Then
        msg = "Error # " & Str(Err.Number) & " was generated by " & _
            Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
        Debug.Print msg, , "Error", Err.HelpFile, Err.HelpContext
    End If
    Resume Here2


End Sub



'Sort array
Sub QuickSort(varUnique As Variant, first As Long, last As Long)

  Dim vCentreVal As Variant, vTemp As Variant

  Dim lTempLow As Long
  Dim lTempHi As Long
  lTempLow = first
  lTempHi = last

  vCentreVal = varUnique((first + last) \ 2)
  Do While lTempLow <= lTempHi

    Do While varUnique(lTempLow) < vCentreVal And lTempLow < last
      lTempLow = lTempLow + 1
    Loop

    Do While vCentreVal < varUnique(lTempHi) And lTempHi > first
      lTempHi = lTempHi - 1
    Loop

    If lTempLow <= lTempHi Then

        ' Swap values
        vTemp = varUnique(lTempLow)

        varUnique(lTempLow) = varUnique(lTempHi)
        varUnique(lTempHi) = vTemp

        ' Move to next positions
        lTempLow = lTempLow + 1
        lTempHi = lTempHi - 1

    End If

  Loop

  If first < lTempHi Then QuickSort varUnique, first, lTempHi
  If lTempLow < last Then QuickSort varUnique, lTempLow, last

End Sub

'sort collections
Sub QuickSort2(cUnique As Collection, first As Long, last As Long)

  Dim vCentreVal As Variant, vTemp As Variant

  Dim lTempLow As Long
  Dim lTempHi As Long
  lTempLow = first
  lTempHi = last

  vCentreVal = cUnique((first + last) \ 2)
  Do While lTempLow <= lTempHi

    Do While cUnique(lTempLow) < vCentreVal And lTempLow < last
      lTempLow = lTempLow + 1
    Loop

    Do While vCentreVal < cUnique(lTempHi) And lTempHi > first
      lTempHi = lTempHi - 1
    Loop

    If lTempLow <= lTempHi Then

      ' Swap values
      vTemp = cUnique(lTempLow)

      cUnique.Add cUnique(lTempHi), After:=lTempLow
      cUnique.Remove lTempLow

      cUnique.Add vTemp, Before:=lTempHi
      cUnique.Remove lTempHi + 1

      ' Move to next positions
      lTempLow = lTempLow + 1
      lTempHi = lTempHi - 1

    End If

  Loop

  If first < lTempHi Then QuickSort cUnique, first, lTempHi
  If lTempLow < last Then QuickSort cUnique, lTempLow, last

End Sub

尽管displayalerts = false，仍然会弹出通过VBA删除重复项

2 个答案: