Sub countDif()
Dim rng As Range, r As Range
Dim vntIn As Variant, vntValue As Variant
Dim lngCount() As Long, lngIndex As Long
Dim objSh As Worksheet
Dim lngCalc As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
On Error Resume Next
Set rng = Application.InputBox("Bereich auswählen", "Unterschiedliche Einträge", Selection.Address, Type:=8)
On Error GoTo 0
If Not rng Is Nothing Then
vntIn = rng
vntValue = toArraySorted(vntIn)
Redim lngCount(UBound(vntValue))
For lngIndex = 0 To UBound(vntValue)
lngCount(lngIndex) = Application.CountIf(rng, vntValue(lngIndex))
Next
Set objSh = ThisWorkbook.Worksheets.Add
With objSh
.Name = "Anzahl_" & Format(Now, "dd-MM-yy hhmmss")
.Cells(1, 1).Resize(UBound(vntValue, 1), 1) = Application.Transpose(vntValue)
.Cells(1, 2).Resize(UBound(vntValue, 1), 1) = Application.Transpose(lngCount)
End With
End If
ErrExit:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'countDif'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Modul - Modul1"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With
End Sub
Public Function toArraySorted(Field As Variant, Optional Uniqe As Boolean = True) As Variant
Dim objArrayList As Object
Dim lngR As Long, lngC As Long
On Error GoTo ErrExit
Set objArrayList = CreateObject("System.Collections.Arraylist")
With objArrayList
For lngR = LBound(Field, 1) To UBound(Field, 1)
For lngC = LBound(Field, 2) To UBound(Field, 2)
If Not .Contains(Field(lngR, lngC)) Or Not Uniqe Then
If Field(lngR, lngC) <> "" Then .Add Field(lngR, lngC)
End If
Next
Next
.Sort
toArraySorted = .toArray
End With
Exit Function
ErrExit:
toArraySorted = -1
End Function
Deine neue Aufgabe muss ich mir erst anschauen, mit mehreren Ausgaben dauert das aber dann bestimmt noch (viel) länger.