通过VBA删除重复项仍然会popup，尽pipedisplayalerts = false

电子表格中的列C包含将被客户端select并经常更新的值。 我想要列D有数据validation应用dynamic，从该列表拉。 但是，它需要包含按字母顺序排列的唯一值。

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

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

要dynamic更新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列的单元格，它仍然会popup一个名为“删除重复”的popup框，显示两个选中的checkbox – “全选”和“列BL”。 它还会告诉我find了多less重复项，并保留了多less个唯一值。

我为什么displayalerts = false为什么没有把这个closures，但它绝对不是一个选项，每次有人在列D点击这个火。有没有人看到这之前？ （顺便说一句，我在Mac上的Excel 2016）。

Answer 1

我还没有find一种方法来抑制或自动接受popup框，这是导致进一步的问题，因为这意味着我所select的列D中的单元格不再select，所以我不能select从下降下拉列表。 但是，我想知道是否有任何人可能比我上面的方法更简单的替代想法。

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

• 上面的场景中，我只需要从C列中的唯一值拉到D列中的数据validation下拉列表中。

• 我还需要创build基于当前不在列表格式的另一个页面上的值的下拉列表。 例如，在下面的代码中，我正在寻找当前在另一个页面的标题中的任何值（即单元格被合并）。 现在我是查找/复制/粘贴/validation，但这似乎很复杂。 当然，它也遇到了与场景1相同的popup式问题。

   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

我find了一个使用RemoveDuplicates来达到预期效果的方法。 感谢Jean-Francois Corbett和SJR提供的一些构build该解决scheme的代码。 见下文：

 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