Filter nachbauen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Rene,
so?

' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub filter()
  Dim MA(1 To 10) As String, MAFilter() As Variant, lngIndex As Long

  MA(1) = "Schulze"
  MA(2) = "Müller"
  MA(3) = "Schmidt"
  MA(4) = "Meier"
  MA(5) = "Meier"
  MA(6) = "Schulze"
  MA(7) = "Schulze"
  MA(8) = "Meier"
  MA(9) = "Schmidt"
  MA(10) = "Schmidt"

  MAFilter = UniqueList(MA)

  For lngIndex = LBound(MAFilter) To UBound(MAFilter)
    Debug.Print MAFilter(lngIndex)
  Next

End Sub

Function UniqueList(Matrix As Variant, Optional Sorted As Boolean = True) As Variant
  Dim objDic As Object, lngIndex As Long, varTmp() As Variant

  Set objDic = CreateObject("Scripting.Dictionary")

  For lngIndex = LBound(Matrix) To UBound(Matrix)
    objDic(Matrix(lngIndex)) = 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

Gruß Sepp

Hallo rene,
so wird richtig sortiert, egal ob Zaheln oder Text.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit
Option Compare Text

Sub filter()
  Dim MA(1 To 10) As Variant, MAFilter() As Variant, lngIndex As Long

  MA(1) = "Zöckler"
  MA(2) = "Müller"
  MA(3) = "de Vos"
  MA(4) = "Zöckler"
  MA(5) = "Zwerenz"
  MA(6) = "van Heiss"
  MA(7) = "Schulze"
  MA(8) = "Meier"
  MA(9) = "van den Boom"
  MA(10) = "Özsahin"

  MAFilter = UniqueList(MA)

  For lngIndex = LBound(MAFilter) To UBound(MAFilter)
    Debug.Print MAFilter(lngIndex)
  Next

End Sub

Function UniqueList(Matrix As Variant, Optional Sorted As Boolean = True) As Variant
  Dim objDic As Object, lngIndex As Long, varTmp() As Variant

  Set objDic = CreateObject("Scripting.Dictionary")

  For lngIndex = LBound(Matrix) To UBound(Matrix)
    objDic(Matrix(lngIndex)) = 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

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread