问题
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.
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))}
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
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.
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).
回答1:
I still haven't found a way to suppress or auto-accept the pop-up box, which is causing further problems because it means the cell in column D that I select is no longer selected, so I can't choose from the drop-down list. However, I'm wondering if anyone has any alternate ideas that might be simpler than my approach above.
Essentially I have two different scenarios that I need to achieve:
- The above scenario, in which I need to pull only unique values from column C into a data validation drop down in column D.
I also need to create drop-down lists based on values on another page that are not currently in list format. For example, in the code below I am looking for any value that is currently in a header on another page (i.e. the cells are merged). Right now I am Find/Copy/Paste/Validating but this seems complicated. And of course it suffers from the same pop-up issue as scenario 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 cEnd If
回答2:
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
来源：https://stackoverflow.com/questions/46414881/removing-duplicates-through-vba-still-throws-pop-up-despite-displayalerts-false