Hallo,
folgende Lösung liefert diese Ergebnisse:
19122-S307 |
Groß |
19023-S315 |
Klein |
19122-S307 |
Groß |
12356-S353 |
In |
19122-S307 |
Groß |
10565-S369 |
Klein |
|
|
Groß |
1 |
Klein |
2 |
In |
1 |
Folgende Funktion kommt hier zum Einsatz:
=AnzahlAufträge($A$1:$B$6; A8)
A1:B6 verweist auf die Daten; A8 verweist auf "Groß"
Die VBA-Funktion ist so aufgebaut:
Option Explicit
Function AnzahlAufträge(Daten As Range, Art As String)
Dim cnt As Integer
Dim iRow As Integer
Dim arData As Variant
Dim tmpAuftrag As String
arData = Daten.Value
QuickSortArray SortArray:=arData, lngColumn:=2
For iRow = LBound(arData, 1) To UBound(arData, 1)
'Debug.Print arData(iRow, 1), arData(iRow, 2)
If arData(iRow, 2) = Art Then
If Not arData(iRow, 1) = tmpAuftrag Then
cnt = cnt + 1
tmpAuftrag = arData(iRow, 1)
End If
End If
Next
AnzahlAufträge = cnt
End Function
Public Sub QuickSortArray(ByRef SortArray As Variant, Optional lngMin As Long = -1, Optional lngMax As Long = -1, Optional lngColumn As Long = 0)
On Error Resume Next
' Quelle: https://stackoverflow.com/questions/4873182/sorting-a-multidimensionnal-array-in-vba
'Sort a 2-Dimensional array
' SampleUsage: sort arrData by the contents of column 3
'
' QuickSortArray arrData, , , 3
'
'Posted by Jim Rech 10/20/98 Excel.Programming
'Modifications, Nigel Heffernan:
' ' Escape failed comparison with empty variant
' ' Defensive coding: check inputs
Dim i As Long
Dim j As Long
Dim varMid As Variant
Dim arrRowTemp As Variant
Dim lngColTemp As Long
If IsEmpty(SortArray) Then
Exit Sub
End If
If InStr(TypeName(SortArray), "()") < 1 Then 'IsArray() is somewhat broken: Look for brackets in the type name
Exit Sub
End If
If lngMin = -1 Then
lngMin = LBound(SortArray, 1)
End If
If lngMax = -1 Then
lngMax = UBound(SortArray, 1)
End If
If lngMin >= lngMax Then ' no sorting required
Exit Sub
End If
i = lngMin
j = lngMax
varMid = Empty
varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)
' We send 'Empty' and invalid data items to the end of the list:
If IsObject(varMid) Then ' note that we don't check isObject(SortArray(n)) - varMid *might* pick up a valid default member or property
i = lngMax
j = lngMin
ElseIf IsEmpty(varMid) Then
i = lngMax
j = lngMin
ElseIf IsNull(varMid) Then
i = lngMax
j = lngMin
ElseIf varMid = "" Then
i = lngMax
j = lngMin
ElseIf VarType(varMid) = vbError Then
i = lngMax
j = lngMin
ElseIf VarType(varMid) > 17 Then
i = lngMax
j = lngMin
End If
While i <= j
While SortArray(i, lngColumn) < varMid And i < lngMax
i = i + 1
Wend
While varMid < SortArray(j, lngColumn) And j > lngMin
j = j - 1
Wend
If i <= j Then
' Swap the rows
ReDim arrRowTemp(LBound(SortArray, 2) To UBound(SortArray, 2))
For lngColTemp = LBound(SortArray, 2) To UBound(SortArray, 2)
arrRowTemp(lngColTemp) = SortArray(i, lngColTemp)
SortArray(i, lngColTemp) = SortArray(j, lngColTemp)
SortArray(j, lngColTemp) = arrRowTemp(lngColTemp)
Next lngColTemp
Erase arrRowTemp
i = i + 1
j = j - 1
End If
Wend
If (lngMin < j) Then Call QuickSortArray(SortArray, lngMin, j, lngColumn)
If (i < lngMax) Then Call QuickSortArray(SortArray, i, lngMax, lngColumn)
End Sub
Die Sub "QuickSortArray" stammt aus einer anderen Quelle.
|