Microsoft Excel

Herbers Excel/VBA-Archiv

Filter nachbauen | Herbers Excel-Forum


Betrifft: Filter nachbauen von: Rene Richter
Geschrieben am: 16.01.2010 10:44:46

Hallo, ich habe große Datenmengen und möchte in VBA so etwas ähnliches wie die 'Filter' nachbauen. Wie geht das?

Bsp:
Dim MA(1000000)
Dim MAFilter(100)

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"

Dieses Datenfeld fülle ich natürlich mit wesentlich mehr Daten. Nun möchte ich als Output folgendes haben.

MAFilter(1) = "Meier"
MAFilter(2) = "Müller"
MAFilter(3) = "Schmidt"
MAFilter(4) = "Schulze"

Das Ergebnis ist also sortiert und jeder Wert taucht nur einmal auf. So etwas gibt es ja bei den Filtern. Aber ich kann auf Grund der großen Datenmenge meine Werte NICHT in Tabellen schreiben und daraus lesen, sondern möchte unbedingt das ganze nur im VBA-Code mit Variablen und Datenfeldern machen. Das Schreiben der Daten würde einfach zu lang dauern (das habe ich nämlich schon probiert). Gibt es dafür vielleicht eine fertige Routine oder hat jemand eine Idee, wie ich so etwas selber bauen kann?

Meiner Meinung nach ist das die Funktionalität eines Filters nur im VBA-Code selber nachgebaut.

  

Betrifft: AW: Filter nachbauen von: Josef Ehrensberger
Geschrieben am: 16.01.2010 10:53:01

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



  

Betrifft: AW: Filter nachbauen von: Rene
Geschrieben am: 16.01.2010 14:38:47

ja sehr genial. Das hilft mir sehr viel weiter. Vielen Dank für den tollen Tipp!!!


  

Betrifft: AW: Filter nachbauen von: Rene
Geschrieben am: 16.01.2010 14:50:41

Oh, ein Problem habe ich jetzt doch noch. Und zwar sieht das Ende meiner Liste folgendermaßen aus:
...
...
...
Zwerenz
Zöckler
de Vos
van Heiss
van den Boom
Özsahin

Hier scheint die Sortierung doch nicht richtig zu funktionieren, oder habe ich da was falsch gemacht.

Und wie ist es bei Zahlen? In manchen "Feldern" habe ich auch Zahlen. Das weiß ich aber vorher, ob die Liste numerisch oder alphanumerisch ist. Gibts da vielleicht noch so einen tollen Tipp?

Vielen Dank an euch Profis!


  

Betrifft: AW: Filter nachbauen von: Josef Ehrensberger
Geschrieben am: 16.01.2010 15:27:30

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



  

Betrifft: AW: Filter nachbauen von: Rene
Geschrieben am: 17.01.2010 08:26:57

super, sehr genial. Vielen Dank.

jetzt baue ich die Routine in mein Projekt ein und bin ein große Last los. einen schönen Sonntag noch.


Beiträge aus den Excel-Beispielen zum Thema "Filter nachbauen"