我采用了一种不同的、可能更复杂的方法。您可以直接在工作表上指定条件。
函数是UniqueNames（数据范围，名称范围，规则范围，可选AndRules = True，可选PrintNames = False）
这是我的样本表
我在
中使用了该功能 4 次
- 范围（“E16”）为UniqueNames(A1:F11,G1:G11,A13:B16,FALSE)
- 范围（“E17”）为UniqueNames(A1:F11,G1:G11,A13:B16)
- 范围（“F16”）为UniqueNames(A1:F11,G1:G11,A13:B16,FALSE,TRUE)
- Range("F17") as UniqueNames(A1:F11,G1:G11,A13:B16,,TRUE)
以下条件运算符是可接受的=,<,>,<=,>=,!=
运算符后面必须跟一个空格，并且
- 一个常数值例如完成
- 一个值的函数，例如状态（项目#6）
空条件无效
代码如下：注意：还有一个私有函数
Public Function UniqueNames(DataSource As Range, ResultsSource As Range, RulesSource As Range, _
Optional AndRules As Boolean = True, Optional PrintNames As Boolean = False) As String
' Return N unique names and who
' Split Indexed Expressions
Dim iChar As Integer
' Expression to eval
Dim Expression() As String
Dim expr As Variant
' Results
Dim Results As Variant
' Get Data into variant array
Dim Data As Variant
' Get Rules into variant array of NRows x 2
Dim Rules As Variant
iChar = 0
Data = DataSource
If RulesSource.Columns.Count = 1 Then
Rules = Union(RulesSource, RulesSource.Offset(0, 1))
ElseIf RulesSource.Columns.Count > 2 Then
Rules = RulesSource.Resize(RulesSource.Rows.Count, 2)
Else
Rules = RulesSource
End If
Results = ResultsSource.Resize(ResultsSource.Rows.Count, UBound(Rules))
For i = LBound(Rules) + 1 To UBound(Rules)
For j = LBound(Data, 2) To UBound(Data, 2)
If Rules(i, 1) = Data(1, j) Then
' rules must be "operator condition"
Expression = Split(Rules(i, 2), " ", 2)
Expression(1) = Trim(Expression(1))
' determine which expression is this
' Convert expression when an item of something e.g. EndDate(10)
iChar = InStr(Expression(1), "(")
If iChar > 0 Then
expr = ExprToVal(Data, Left$(Expression(1), iChar - 1), _
Mid$(Expression(1), iChar + 1, Len(Expression(1)) - iChar - 1))
Else
expr = Expression(1)
End If
For k = LBound(Data, 1) + 1 To UBound(Data, 1)
Results(k, i) = False
Select Case (Expression(0))
Case "="
If Data(k, j) <> "" And LCase$(Data(k, j)) = LCase$(expr) Then Results(k, i) = True
Case "<"
If Data(k, j) <> "" And LCase$(Data(k, j)) < LCase$(expr) Then Results(k, i) = True
Case ">"
If Data(k, j) <> "" And LCase$(Data(k, j)) > LCase$(expr) Then Results(k, i) = True
Case "<="
If Data(k, j) <> "" And LCase$(Data(k, j)) <= LCase$(expr) Then Results(k, i) = True
Case ">="
If Data(k, j) <> "" And LCase$(Data(k, j)) >= LCase$(expr) Then Results(k, i) = True
Case "!="
If Data(k, j) <> "" And LCase$(Data(k, j)) <> LCase$(expr) Then Results(k, i) = True
End Select
Next k
End If
Next j
Next i
' create one list where all three rules are true
Data = Results
Set Results = Nothing
ReDim Results(LBound(Data, 1) + 1 To UBound(Data, 1), 1 To 2) As Variant
' results now has the names w/a number representing how many rules were met
For i = LBound(Data, 1) + 1 To UBound(Data, 1)
Results(i, 1) = Data(i, 1)
Results(i, 2) = 0
For j = LBound(Data, 2) + 1 To UBound(Data, 2)
If Data(i, j) Then Results(i, 2) = Results(i, 2) + 1
Next j
Next i
' put that back into data
Data = Results
Set Results = Nothing
Results = ""
For i = LBound(Data, 1) + 1 To UBound(Data, 1)
If Data(i, 2) = UBound(Rules, 1) - LBound(Rules, 1) Then
Results = Results & Data(i, 1) & ";"
ElseIf AndRules = False And Data(i, 2) > 0 Then
Results = Results & Data(i, 1) & ";"
End If
Next i
' split that into expression
Expression = Split(Results, ";")
For i = LBound(Expression) To UBound(Expression)
For j = i + 1 To UBound(Expression)
If Expression(i) = Expression(j) Then Expression(j) = ""
Next j
Next i
iChar = 0
Results = ""
For i = LBound(Expression) To UBound(Expression)
If Expression(i) <> "" Then
Results = Results & Expression(i) & ";"
iChar = iChar + 1
End If
Next i
UniqueNames = ""
If PrintNames Then
' prints number of unique names and the names
UniqueNames = Results
Else
' prints number of unique names
UniqueNames = CStr(iChar)
End If
End Function
Private Function ExprToVal(Data As Variant, expr As String, Index As String) As Variant
Dim Row As Integer
Dim Col As Integer
Dim sCol As Variant
' Get what type of data this is
For i = LBound(Data, 2) To UBound(Data, 2)
sCol = Replace(Index, Data(1, i), "", 1, 1, vbTextCompare)
If IsNumeric(sCol) Then
Col = i
Exit For
ElseIf LCase$(Left$(Index, Len(Data(1, i)))) = LCase$(Data(1, i)) Then
Col = i
Exit For
End If
Next i
' now find the row of the value
For i = LBound(Data, 1) + 1 To UBound(Data, 1)
If LCase$(Data(i, Col)) = LCase$(sCol) Then
Row = i
Exit For
End If
Next i
' find the column of the value
For i = LBound(Data, 2) To UBound(Data, 2)
If LCase$(Data(1, i)) = LCase$(expr) Then
Col = i
Exit For
End If
Next i
If Row >= LBound(Data, 1) And Row <= UBound(Data, 1) And _
Col >= LBound(Data, 2) And Col <= UBound(Data, 2) Then
ExprToVal = Data(Row, Col)
Else
ExprToVal = ""
End If
End Function