尽管displayalerts = false，通过VBA删除重复项仍会弹出 [英] Removing Duplicates through VBA still throws pop up despite displayalerts=false

问题描述

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

Column C in my spreadsheet contains values that will be client-chosen and frequently updated. I want column D to have data validation applied dynamically that pulls from that list. However, it needs to contain alphabetically ordered, unique values.

我当前正在做的是使用以下公式按字母顺序对这些值在隐藏列(BK)中进行排序. (请注意:我在其上找到该网站的网站指示该网站仅应显示唯一值，但不应显示唯一值).

What I am currently doing is using the following formula to alphabetically order those values in a hidden column (BK). (Note: the site I found this on indicated it should only show unique values, however it did not).

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

要动态更新D列，我正在使用以下代码:

To update column D dynamically, I am using the following code:

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列".它还告诉我发现了多少重复项以及将保留多少唯一值.

This seems to work, except every time I click in a cell in column D it still throws a pop up box called "Remove Duplicates" that shows two checked checkboxes -- "Select All" and "Column BL". It also tells me how many duplicates were found and how many unique values will remain.

我很茫然，为什么displayalerts = false并没有将其关闭，但是每次有人单击D列时，都不会发生这种情况.这是绝对不可行的.以前有没有人看到过? (顺便说一下，我在Excel for Mac 2016上).

I am at a loss for why displayalerts=false hasn't turned this off, but it definitely isn't an option to have this fire every time someone clicks in column D. Has anyone seen this before? (I am on Excel for Mac 2016 by the way).

推荐答案

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

I found a way around using RemoveDuplicates to achieve the desired result. Credit to Jean-Francois Corbett and SJR for some of the code that builds this solution. See below:

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删除重复项仍会弹出的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！