Kniffeliges VBA-Thema

[CoreoG]

Liebe VBA-Tüftler!

Wahrscheinlich ist es ganz easy, nur ich bin ein VB-Anfänger und suche eine Lösung für folgende Herausforderung:

Ich möchte eine Tabelle auf übereinstimmende Werte durchsuchen:

Erster Wert stammt aus einem Userform-Textfeld. Zusätlich soll aber auch eine weitere Bedingung stammend aus der gleichen Userform-Listbox erfüllt werden. Wenn diese beiden Bedingungen erfüllt sind, dann sollen die Spalten b, c und d der entsprechenden Zeile kopiert und in ein neues Tabellenblatt eingefügt werden.

Leider fehlt mir ein guter Ansatz wie ich das angehen soll ... kann mir jemand weiterhelfen?

 

[CoreoG]

Kann jemand helfen, bin am verzweifeln ....

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

 

[Yaslaw]

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]

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.

 

[Yaslaw]

Poste mal ein Beispiel deiner Tabelle, dann wird einiges klarer.

 

[CoreoG]

Großkunden	Klasse	Gruppe	Name	Adresse 1	Telefonnummer
	A	rot	Elisabeth Müller	Adresse 2	042242158
	A	gelb	Anita Sowieso	Adresse 3	0316228599
	A	grün	Bernd Heiter	Adresse 4	0318228599
	A	blau	Rubi Rot	Adresse 5	0422766666
	A	blau	Elsa Breit	Adresse 6	06642287755
	B	blau	Alexander Moor	Adresse 7	k.A.
	B	blau	Beate Früh	Adresse 8	0676331254
	B	blau	Heinrich Spät	Adresse 9	0699123564
	B	grün	Carmen Lehner	Adresse 10	0664218897
	B	violett	Arthur Grau	Adresse 11	0699572186
	B	orange	Helga Schnabel	Adresse 12	0650212121

 

[CoreoG]

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]

Ich habe mal ein wenig Code geschrieben und getestet.

Im UserForm habe ich die Funktion um den Prozess zu starten

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

'/**
' * @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

 

[CoreoG]

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!

 

[Yaslaw]

Union und Intersect kannte ich vorher auch nicht. Bin bei der Suche darauf gestossen...