Kniffeliges VBA-Thema


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

CoreoG

Grünschnabel
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

Grünschnabel
Hab noch keine Lösung gefunden ....

Zuerst hab ich die Idee vom Advanced Filter verfolgt, da hab ich aber das Thema, dass bei der Listbox auch eine Mehrfachauswahl möglich ist. Also wäre es wahrscheinlich eleganter, das über die Find-Funktion/Methode zu lösen .... aber wie?
 
Zuletzt bearbeitet:

Zvoni

Erfahrenes Mitglied
Wieso kennzeichnest du dann den Thread als gelöst?

Was dein Problem betrifft: Finde die letzte Zeile in deinem Excel-Blatt, laufe durch dein Excel-Blatt und vergleiche die Textbox sowie den Listbox-Eintrag mit Zelle in Spalte A, falls Treffer, schreibe in Blatt2.
 

CoreoG

Grünschnabel
sorry, bin neu hier, das hab ich nicht gesehen, dass ich den Thread als gelöst gekennzeichnet hab.

Danke für die Antwort! Ich werde das mal versuchen umzusetzen! Kann sein, dass ich mich nochmal melde! ;-)
 

CoreoG

Grünschnabel
Komme einfach nicht weiter ...

Ich muss nämlich in meinem Tabellenblatt eine Spalte mit Namen "Klasse" (erste Zeile) finden.
Wenn gefunden, dann soll diese Spalte auf den Wert aus einer Userform-Textbox durchsucht werden.

Alle Reihen in denen dieser Wert gefunden wird, sollen auf weitere Suchbegriffe, die aus einer multiselect Listbox kommen, durchsucht werden.

Und jetzt kommts: Wenn keine weiteren Suchbegriffe ausgewählt wurden, dann sollen alle Zeilen mit Übereinstimmung aus Auswahl A in Tabellenblatt 2 kopiert werden, sonst nur jene mit beiden Treffern.

Hab mal versucht die erste Auswahl herzuleiten, aber es klappt ganz und gar nicht ....

Visual Basic:
Dim wks_Liste As Worksheet
Dim wks_Resultate As Worksheet
Set wks_Liste = Worksheets(wsn_Liste)
wks_Liste.Activate

Dim sParameter As Range
Dim firstAddress As String


Application.ScreenUpdating = False


Set sParameter = Worksheets(wsn_Liste).UsedRange.Find(What:=txbKlasse.Text, LookIn:=xlValues, lookat:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True _
        , SearchFormat:=False)

If Not sParameter Is Nothing Then
        firstAddress = sParameter.Address
   
            Do
            Cells(sParameter.Row).Copy Destination:=wks_Resultate("B2")
            Set sParameter = FindNext(sParameter)
            Loop While Not sParameter Is Nothing And sParameter <> firstAddress
End If
   
Application.ScreenUpdating = True
 
Zuletzt bearbeitet von einem Moderator:

CoreoG

Grünschnabel
Über Find(What:=txbKlasse.Text ...) gebe ich an, wonach zuerst gesucht werden soll.

Die zweite Auswahl bereitet mir noch mehr kopfzerbrechen, weil da können aus der Listbox bis zu 10 Werte bzw. auch keiner ausgewählt werden. Wenn keiner ausgewählt ist, dann soll nur nach Auswahl 1 "gefiltert" werden.

Ich scheitere leider schon daran die Herangehensweise zu definieren. Nehme ich eine If-Anweisung eine Do-Loop Anweisung oder With bzw. wie kann ich das ganze kombinieren ....
 

Yaslaw

n/a
Moderator
Das habe ich verstranden. Aber wie gesagt, ich kenne die Forms nicht. Wie kommst du an die Werte aus der Listbox?
 

CoreoG

Grünschnabel
Visual Basic:
Dim cGroup As Range

    For i = 0 To LboGroup.ListCount - 1
        If LboGroup.Selected(i) = True Then _
            Set cGroup = Worksheets(wsn_Liste).UsedRange.Find(What:=LboGroup.Selected(i), LookIn:=xlValues, lookat:= _ xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True _
            , SearchFormat:=False)
            Next i
        End If


Das wäre die Idee wie ich an die Werte aus der Listbox komme...
 
Zuletzt bearbeitet:

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

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…