如何查看所有比赛
如果我有
ID String
1 xxx
2 yyy
1 zzz
3 ooo
1 ppp
1 zzz
我需要vlookup ID = 1 anf get in one cell
xxx
zzz
ppp
Application.Vlookup(1;A2:B7;2;False)
仅发现第一个发现者
如何找到所有独特的匹配?
答案 0 :(得分:0)
对于给定的问题,VLOOKUP方法无济于事。所以你必须使用ROW和INDEX数组公式。
使用记录宏功能:
' Apply the formula to retrieve the matching value
Selection.FormulaArray = _
"=INDEX(R2C1:R7C2,SMALL(IF(R2C1:R7C1=1,ROW(R2C1:R7C1)),ROW(R[-9]))-1,2)"
Selection.AutoFill Destination:=Range("A10:A13"), Type:=xlFillDefault
' Get the unique values by removing the duplicate
ActiveSheet.Range("$A$10:$A$13").RemoveDuplicates Columns:=1, Header:=xlNo
使用VBA代码
findValue = 1
totalRows = Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
j = 1
For i = 2 To totalRows
If Cells(i, 1).Value = findValue Then
' Fill in the D:D range
Cells(j, 4).Value = Cells(i, 2).Value
j = j + 1
End If
Next
ActiveSheet.Range("D:D").RemoveDuplicates Columns:=1, Header:=xlNo
答案 1 :(得分:0)
您需要创建一个UDF才能执行此操作。请复制并粘贴以下代码。 (请记住要对Dictionary对象进行早期绑定 - 在VBE中的工具 - 参考对话框中检查 Microsoft Scripting Runtime 。 您可以在http://www.cnblogs.com/hejing195/p/8198584.html)
中找到一些详细的说明和屏幕截图Function LookUpAllMatches(ByVal lookup_value As String, _
ByVal match_range As Range, _
ByVal return_range As Range, Optional ByVal return_array = False, _
Optional ByVal remove_duplicate = False, _
Optional ByVal delimiter As String = ",")
'By Jing He 2017-12-29
'Last update 2018-02-02
Dim match_index() As Long, result_set() As String
ReDim match_index(1 To match_range.Cells.Count)
Set match_range = zTrim_Range(match_range)
Set return_range = zTrim_Range(return_range)
If match_range.Count <> return_range.Count Then
LookUpAllMatches = "Number of cells in trimed match_range and in trimed return_range are not equal."
Exit Function
End If
Dim i As Long, mc As Long 'used to count, to get the index of a cell in a range
mc = 0 'match count
For i = 1 To match_range.Cells.Count
If match_range.Cells(i).Value = lookup_value Then
mc = mc + 1
match_index(mc) = i
End If
Next i
If mc = 0 Then Exit Function
'Removing duplicate process. Use Scripting.Dictionary object.
If remove_duplicate Then
Dim d As Dictionary, key As String
Set d = New Dictionary
For i = 1 To mc
key = return_range.Cells(match_index(i)).Value
If Not d.Exists(key) Then d.Add key, key
Next i
ReDim result_set(1 To d.Count)
'Convert the hashtable to a array of all the values
its = d.Items
'the index of this items array starts at 0 instead of 1 which is the standard for all the other arraries in ths UDF.
For i = 0 To d.Count - 1
result_set(i + 1) = its(i)
Next i
'close the object; release memeory
Set d = Nothing
Else
ReDim result_set(1 To mc)
For i = 1 To mc
result_set(i) = return_range.Cells(match_index(i)).Value
Next i
End If
If return_array Then
LookUpAllMatches = result_set
Exit Function
End If
Dim result As String
'Convert result_set to a single-line text
result = result_set(1)
For i = 2 To UBound(result_set)
result = result & delimiter & result_set(i)
Next i
LookUpAllMatches = result
End Function
Function zTrim_Range(ByVal rng As Range) As Range
'By Jing He 2017-12-29
'Last update 2017-12-29
Dim maxRow As Long, maxUsedRow As Long, maxUsedRowTemp As Long
maxRow = Columns(1).Cells.Count
If rng.Cells.Count \ maxRow <> 0 Then
'One or multiple columns selected
For i = 1 To rng.Columns.Count
If Cells(maxRow, rng.Cells(1, i).Column) = "" Then
maxUsedRowTemp = Cells(maxRow, rng.Cells(1, i).Column).End(xlUp).Row
If maxUsedRowTemp > maxUsedRow Then maxUsedRow = maxUsedRowTemp
End If
Next i
Set zTrim_Range = Intersect(rng, Range(Rows(1), Rows(maxUsedRow)))
Else
Set zTrim_Range = rng
End If
End Function