AW: Suche: Bei welcher Veranstaltungen waren Beide am Start?
11.11.2024 18:04:03
emkaes
Hi,
hier mal ein Ansatz mit AdvancedFilter und Dictionary mit VBA
Datei benötigt eine weitere Tabelle ( Output ) und einen Verweis auf die Scripting Runtime
https://www.herber.de/bbs/user/173528.xlsm
Option Explicit
Public Enum eResultType
list1only = 1
both = 2
list2only = 3
End Enum
Function useAdvancedFilterCopy(rgData As Range, rgCriteria As Range, rgOutput As Range) As Dictionary
Dim arr As Variant
Dim dict As New Dictionary
Dim i As Long
On Error GoTo fin
rgOutput.CurrentRegion.ClearContents
rgData.AdvancedFilter xlFilterCopy, rgCriteria, rgOutput
arr = rgOutput.CurrentRegion.Offset(1).Resize(rgOutput.CurrentRegion.Rows.Count - 1).Value2
rgOutput.CurrentRegion.ClearContents
For i = LBound(arr) To UBound(arr)
dict(arr(i, 1)) = 0
Next
Set useAdvancedFilterCopy = dict
Exit Function
fin:
MsgBox "es ist Fehler aufgetreten"
End Function
Sub callfilter()
Dim sPerson1 As String, sPerson2 As String
Dim rgData As Range, rgCriteria As Range, rgOutput As Range
Dim dictResult As New Dictionary
Dim dictList1 As New Dictionary
Dim dictList2 As New Dictionary
Set rgData = Worksheets("Tabelle1").Range("A8").CurrentRegion
Set rgCriteria = Worksheets("Tabelle1").Range("A1").CurrentRegion
Set rgOutput = Worksheets("Output").Range("A1")
rgData.AutoFilter
sPerson1 = InputBox("Sportler1")
If StrPtr(sPerson1) = 0 Then
MsgBox " ungültiger Input"
Exit Sub
Else
rgCriteria.Cells(5).Value = sPerson1
Set dictList1 = useAdvancedFilterCopy(rgData, rgCriteria, rgOutput)
End If
sPerson2 = InputBox("Sportler2")
If StrPtr(sPerson2) = 0 Then
MsgBox " ungültiger Input"
Exit Sub
Else
rgCriteria.Cells(5).Value = sPerson2
Set dictList2 = useAdvancedFilterCopy(rgData, rgCriteria, rgOutput)
End If
Set dictResult = compareList(dictList1, dictList2, both)
If dictResult.Count > 0 Then
With rgData
.AutoFilter
.AutoFilter Field:=1, Criteria1:=dictResult.Keys, Operator:=xlFilterValues
.AutoFilter Field:=2, Criteria1:=sPerson1, Operator:=xlOr, Criteria2:=sPerson2
End With
Else
MsgBox "Sportler nicht gegeneinander angetreten"
End If
End Sub
Public Function compareList(dict1 As Dictionary, dict2 As Dictionary, rtype As eResultType) As Dictionary
Dim dictResult As New Dictionary, dict2Only As New Dictionary
Dim item As Variant
For Each item In dict2
If dict1.Exists(item) = True Then
dictResult(item) = 0
dict1.Remove item
Else
dict2Only(item) = 0
End If
Next
Select Case rtype
Case both
Set compareList = dictResult
Case list1only
Set compareList = dict1
Case list2only
Set compareList = dict2Only
End Select
End Function