我找到了一种使用 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