' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub auswerten()
Dim rng As Range
Dim vntList As Variant, vntResult(1 To 30, 1 To 3) As Variant
Dim lngIndex As Long
With Sheets("Listen")
Set rng = Union(.Range("B4:B33"), .Range("F4:F33"), .Range("J4:J33"))
vntList = UniqueList(rng)
End With
For lngIndex = 0 To UBound(vntList)
vntResult(lngIndex + 1, 1) = vntList(lngIndex)
With Sheets("Stammverzeichnis")
vntResult(lngIndex + 1, 2) = .Cells(Application.Match(vntList(lngIndex), .Range("A2:A31"), 0) + 1, 2)
End With
With Sheets("Listen")
vntResult(lngIndex + 1, 3) = _
Application.SumIf(.Range("B4:B33"), vntList(lngIndex), .Range("D4:D33")) + _
Application.SumIf(.Range("F4:F33"), vntList(lngIndex), .Range("H4:H33")) + _
Application.SumIf(.Range("J4:J33"), vntList(lngIndex), .Range("L4:L33"))
End With
Next
Sheets("Auswertung").Range("B4").Resize(UBound(vntResult, 1), UBound(vntResult, 2)) = vntResult
End Sub
Private Function UniqueList(Matrix As Range, Optional VisibleCellsOnly As Boolean = True, _
Optional IncludeNull As Boolean = True, Optional Sorted As Boolean = True) As Variant
Dim objDic As Object, rng As Range, varTmp() As Variant, vntExclude As Variant
Set objDic = CreateObject("Scripting.Dictionary")
vntExclude = IIf(IncludeNull, "", 0)
If VisibleCellsOnly Then Set Matrix = Matrix.SpecialCells(xlCellTypeVisible)
For Each rng In Matrix.Cells
If rng.Value <> vntExclude Then objDic(rng.Value) = 0
Next
varTmp = objDic.keys
If Sorted Then QuickSort varTmp
UniqueList = varTmp
Set objDic = Nothing
End Function
Private Sub QuickSort(data() As Variant, Optional UG, Optional OG)
Dim P1&, P2&, T1 As Variant, T2 As Variant
UG = IIf(IsMissing(UG), LBound(data), UG)
OG = IIf(IsMissing(OG), UBound(data), OG)
P1 = UG
P2 = OG
T1 = data((P1 + P2) / 2)
Do
Do While (data(P1) < T1)
P1 = P1 + 1
Loop
Do While (data(P2) > T1)
P2 = P2 - 1
Loop
If P1 <= P2 Then
T2 = data(P1)
data(P1) = data(P2)
data(P2) = T2
P1 = P1 + 1
P2 = P2 - 1
End If
Loop Until (P1 > P2)
If UG < P2 Then QuickSort data, UG, P2
If P1 < OG Then QuickSort data, P1, OG
End Sub