Option
Explicit
Sub
Tab1To2()
Dim
rngU
As
Range, x
As
Long
Dim
arrB()
As
Variant
, rngZ
As
Range
Sheets(
"Tabelle2"
).Cells.Clear
Sheets(
"Tabelle1"
).Cells.Copy Sheets(
"Tabelle2"
).Cells(1)
With
Sheets(
"Tabelle2"
)
Set
rngU = .UsedRange
Set
rngU = rngU.Offset(1).Resize(rngU.Rows.Count - 1)
arrB = GetDistinct(rngU)
Set
rngZ = .Cells(1, rngU.Columns.Count + 2)
rngZ.Value =
"Fall"
rngZ.Offset(, 1).Value =
"Anzahl"
rngZ.Offset(1).Resize(UBound(arrB) + 1, 1).Value = Application.Transpose(arrB)
For
x = LBound(arrB)
To
UBound(arrB)
If
arrB(x) <>
""
Then
rngZ.Offset(x + 1, 1).Value = WorksheetFunction.CountIf(rngU, arrB(x))
End
If
Next
x
.Columns.AutoFit
End
With
End
Sub
Private
Function
GetDistinct(
ByVal
oTarget
As
Range)
As
Variant
Dim
varArray
As
Variant
Dim
objMyDic
As
Object
Dim
V
As
Variant
Dim
x
As
Long
Set
objMyDic = CreateObject(
"Scripting.Dictionary"
)
varArray = oTarget
For
Each
V
In
varArray
objMyDic(V) = V
x = x + 1
Next
GetDistinct = objMyDic.Items()
Debug.Print x
End
Function