Kniffeliges VBA-Thema

Status
Dieses Thema wurde gelöst! Zur Lösung gehen…

CoreoG

Grünschnabel
Kann jemand helfen, bin am verzweifeln ....


Visual Basic:
Sub Filter()

Const Addr1 = "B2"
Const ColNo = 3

Dim Tab1 As Object, Tab2 As Object
'Dim Klasse As Range, Gruppe As Range, Name As Range
Dim sKlasse As Range, sGruppe As Range
Dim lrow As Integer
Dim wks_Liste As Worksheet
Dim wks_Resultate As Worksheet
Set wks_Liste = Worksheets(wsn_Liste)
    wks_Liste.Activate

'        Klasse = Worksheets(wsn_Liste).UsedRange.Find(What:=Klasse, LookIn:=xlValues, lookat:= _
'         xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column
'
'        Gruppe = Worksheets(wsn_Liste).UsedRange.Find(What:=Gruppe, LookIn:=xlValues, lookat:= _
'         xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column
'
'        Name = Worksheets(wsn_Liste).UsedRange.Find(What:=Name, LookIn:=xlValues, lookat:= _
'         xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column
      
    Set sKlasse = Worksheets(wsn_Liste).UsedRange.Find(What:=txbKlasse.Text, LookIn:=xlValues, lookat:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
    
    
    Set sGruppe = Worksheets(wsn_Liste).UsedRange.Find(What:=lboGruppe.List(i), LookIn:=xlValues, lookat:= _
       xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)

    Application.ScreenUpdating = False
    'Schleife zum durchsuchen von Tabelle1
    For Each i In Range(Addr1, Range(Addr1).End(xlDown))
       If Not sKlasse Is Nothing Then
             ElseIf Not sGruppe Is Nothing Then
                Worksheets(wsn_Liste).Row.Copy Worksheets(wsn_Resultate).Rows(lrow)
                MsgBox "You have selected: " & lboGruppe.List(i)
              
                With Worksheets(wsn_Liste)
                lrow = .Cells(Rows.Count, 1).End(xlUp).Row
                   If lrow = 1 Then lrow = 2 Else lrow = lrow + 3
                   i.EntireRow.Copy Worksheets(wsn_Resultate).Rows(lrow)
                End With
              

             ElseIf sGruppe Is Nothing Then
                MsgBox "Information: You have not choosen any group, so all groups will be selected."
                lboGruppe.Select True
            End If
    Next i
  
    Application.ScreenUpdating = True
  
    End Sub
 
Zuletzt bearbeitet von einem Moderator:

Yaslaw

n/a
Moderator
Alle Reihen in denen dieser Wert gefunden wird, sollen auf weitere Suchbegriffe, die aus einer multiselect Listbox kommen, durchsucht werden.
Die ganze Reihe? ALso die Begridde aus der Listbox sollen in allen Feldern der Zeile gesucht werden?
Und müssen alle ausgewählten Einträge der Listbox gefunden werden oder nur Einer?
 

CoreoG

Grünschnabel
Es gibt Spaltenüberschriften, sodass nur in den Spalten gesucht werden müsste.
In der Spalte "Klasse" soll der Begriff "C" (verknüpft mit Textbox) gesucht werden und in der Spalte "Gruppe" (verknüpft mit Listbox - multiselect möglich) sollen mehrere Begriffe gesucht werden z.B. "gelb" , "grün" , "blau", "rot". Wenn in "Gruppe" keine Auswahl getroffen wurde, dann sollen alle 10 Felder als ausgewählt angenommen werden.
Alle Zeilen, die z.B. enthalten "G" und "gelb" und "grün" sollen in eine weitere Tabelle kopiert werden.
 

CoreoG

Grünschnabel
GroßkundenKlasseGruppeNameAdresse 1Telefonnummer
ArotElisabeth MüllerAdresse 2042242158
AgelbAnita SowiesoAdresse 30316228599
AgrünBernd HeiterAdresse 40318228599
AblauRubi RotAdresse 50422766666
AblauElsa BreitAdresse 606642287755
BblauAlexander MoorAdresse 7k.A.
BblauBeate FrühAdresse 80676331254
BblauHeinrich SpätAdresse 90699123564
BgrünCarmen LehnerAdresse 100664218897
BviolettArthur GrauAdresse 110699572186
BorangeHelga SchnabelAdresse 120650212121
 

CoreoG

Grünschnabel
In dieser Tabelle würde ich gerne nach Klasse B, Gruppe blau und violett filtern und mir Spalte "Klasse", "Gruppe" und "Name" in einem neuen Tabellenblatt ausgeben lassen ...
 

Yaslaw

n/a
Moderator
Ich habe mal ein wenig Code geschrieben und getestet.

Im UserForm habe ich die Funktion um den Prozess zu starten
Visual Basic:
Private Sub cbxGo_Click()
   
    Dim gruppen() As String
   
    Dim i As Long   'Zähler aller möglichen Elemente
    Dim k As Long   'Zähler der ausgewählten Elemente
    k = -1
   
    'Ausgewählte auslesen
    For i = 0 To lbx1.ListCount - 1
        If lbx1.Selected(i) Then
            k = k + 1
            ReDim Preserve gruppen(k)   'Rückgabeliste erweitern
            gruppen(k) = lbx1.List(i)   'und den Wert zuordnen
        End If
    Next i
   
   
    If k = -1 Then
        'Nichts wurde ausgewähl, ergo alle übernehmen
        ReDim gruppen(lbx1.ListCount - 1)
        For i = 0 To lbx1.ListCount - 1
            gruppen(i) = lbx1.List(i)
        Next i
    End If
   
    myAction txt1.value, gruppen
    Unload Me
End Sub

Funktion, welche die Daten sucht kopiert
Visual Basic:
'/**
' * @param  String
' * @param  Array<String>
' */
Sub myAction(ByVal iKlasse, iGruppen() As String)
    Dim colNrKlasse As Integer, colNrGruppe As Integer, colNrName As Integer
    Dim wsSrc As Worksheet
    Dim wsTrg As Worksheet
    Dim cols As Range
   
    'Sheets definieren
    Set wsSrc = ActiveWorkbook.Sheets("DATA")
    Set wsTrg = ActiveWorkbook.Sheets("TARGET")
   
    'Spalten suchen
    colNrKlasse = wsSrc.Range("1:1").Find("Klasse").Column
    colNrGruppe = wsSrc.Range("1:1").Find("Gruppe").Column
    colNrName = wsSrc.Range("1:1").Find("Name").Column
   
    'Filter setzen
    wsSrc.rows("1:1").AutoFilter
    wsSrc.UsedRange.AutoFilter colNrKlasse, iKlasse
    wsSrc.UsedRange.AutoFilter colNrGruppe, iGruppen, xlFilterValues
   
    'Ziel aufräumen
    wsTrg.UsedRange.Clear
   
    'Zu kopierende Spalten
    Set cols = Union(wsSrc.Columns(colNrKlasse), wsSrc.Columns(colNrGruppe), wsSrc.Columns(colNrName))
    'Spalten auf die sichtbaren Zeilen des verwedneten Ranges anwenden und kopieren
    Intersect(cols, wsSrc.UsedRange.SpecialCells(xlCellTypeVisible)).Copy
    'Ziel Daten einfügen
    wsTrg.Cells(1, 1).PasteSpecial
   
    'Filter etc. entfernen
    Application.CutCopyMode = False
    wsSrc.ShowAllData
    wsSrc.UsedRange.AutoFilter
End Sub
 

Anhänge

  • T408557.zip
    104,8 KB · Aufrufe: 1
Zuletzt bearbeitet:

CoreoG

Grünschnabel
Chapeau! Es funktioniert! Die Intersect-Methode habe ich mir angeschaut, mich aber da nicht rangewagt.... Auf die Union-Methode wäre ich nicht gekommen, genial! Wie es aussieht, habe ich noch viel zu lernen! Vielen Dank!
 
Status
Dieses Thema wurde gelöst! Zur Lösung gehen…