通过删除重复VBA仍然抛出尽管displayalerts弹出=在我的电子表格假

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细胞点击每次它仍然抛出一个弹出框称为“Remove Duplicates”，显示两个选中的复选框 - “全选”和“列BL”。它还会告诉我找到了多少重复项，并保留了多少个唯一值。

我在为什么displayalerts =假还没有把这个关闭亏损，但它绝对不是有这个火每次点击列D.有没有人见过这个选项？ （顺便说一下，我在Mac上使用Excel 2016）。

Answer 1

我发现周围使用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 

Answer 2

我还没有找到一种方法来抑制或自动接受弹出框，这是造成进一步的问题，因为这意味着在列d，我选择不再被选中的单元格，所以我不能从下拉列表中选择。 但是，我想知道是否有人有任何可能比我上面的方法更简单的替代想法。

基本上我有我需要实现两种不同的情况：

• 上述场景，在其中我需要从 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 
  

  结束如果