Autofilter per ListBox,sowie neu kopieren (Dani !)
27.05.2005 14:40:19
Pierre
ich habe folgende Aufgabe zu lösen und brauch dazu Hilfe (Keine Ahnung wo mein geschriebener Beitrag hin ist). Jedenfalls, möchte ich mit 2 Listboxen auf Knopfdruck eine Mehrfachauswahl hinbekommen, die dann diese Auswahl hernimmt und von der Ausgangsdatei in ein neues Blatt kopiert?! Habe auch schon einen Code, mit Hilfe von "Dani", jedoch klappt es noch nicht ganz mit der Auswahl, er sucht scheinbar nur die ersten zwei wie es scheint?!
Kurz:
- Arbeitsblatt
- Startknopf mit Grundsätzlicher Filterung, von Ausgangsdatei (hab ich schon mit Recorder aufgezeichnet) entsteht dann Tabelle Gefiltert
- Userform wird gestartet mit 2 Listboxen (links OWNER, rechts PROCESS_GROUP)
- man wählt sich Filter aus (mehrfachauswahl, hab ich auch schon)
- Programm sucht dann in der Tabelle Gefiltert nach diesen Kriterien und Kopierts in Tabelle FERTIG, vieleicht auch gleich mit Überschrift.
https://www.herber.de/bbs/user/23294.xls
Hier nun der Code - bisher, sucht er sich für die linke und rechte Listbox die Kriterien schon raus (also keine Duplikate), und man kann diese mehrfach auswählen, und kopiert auch schon - allerdings leider NUR 2 heraus, warum auch immer?! Vieleicht einfach nur was kurz Ändern, und das war's dann schon, auch gut :-)
Option Explicit
Private Sub CommandButton2_Click()
Dim i, Listenlänge As Long
Dim Fundort As Range
Dim Quelltabelle, Zieltabelle As Worksheet
Set Quelltabelle = Workbooks("Wasserfall.xls").Worksheets("Gefiltert")
Set Zieltabelle = Workbooks("Wasserfall.xls").Worksheets("Tabelle6")
'Filter (OWNER) wählen und in Zeile kopieren
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
Set Fundort = Quelltabelle.Range("C:C").Find(ListBox1.List(i), , , xlWhole)
If Not Fundort Is Nothing Then
'Listenlänge, Zeile frei dazw. ja/nein (1,2)
Listenlänge = 1 + Zieltabelle.Cells(Rows.Count, 1).End(xlUp).Row
Quelltabelle.Range(Fundort.Row & ":" & Fundort.Row).Copy Destination:=Zieltabelle.Range(Listenlänge & ":" & Listenlänge)
End If
End If
Next
'Filter (PROCESS_GROUP) wählen und in Zeile kopieren
For i = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(i) = True Then
Set Fundort = Quelltabelle.Range("D:D").Find(ListBox2.List(i), , , xlWhole)
If Not Fundort Is Nothing Then
'Listenlänge, Zeile frei dazw. ja/nein (1,2)
Listenlänge = 1 + Zieltabelle.Cells(Rows.Count, 1).End(xlUp).Row
Quelltabelle.Range(Fundort.Row & ":" & Fundort.Row).Copy Destination:=Zieltabelle.Range(Listenlänge & ":" & Listenlänge)
End If
End If
Next
End Sub
Private Sub UserForm_Initialize()
Dim ws As Worksheet
Dim xErsteZeile As Long
Dim xZeile As Long
'PROZESSGRUPPEN Spalte D
ThisWorkbook.Worksheets("Gefiltert").Range("C:D").Copy Destination:=Tabelle6.Range("A:A")
Set ws = ThisWorkbook.Worksheets("Tabelle6")
xErsteZeile = ws.Cells(Rows.Count, 1).End(xlUp).Row
For xZeile = xErsteZeile To 1 Step -1
If Application.WorksheetFunction.CountIf(ws.Columns(1), ws.Cells(xZeile, 1).Value) > 1 Then
ws.Rows(xZeile).Delete
End If
Next
'In Listbox übergeben
ListBox1.MultiSelect = fmMultiSelectMulti
ListBox2.MultiSelect = fmMultiSelectMulti
ListBox1.RowSource = "Tabelle6!A1:A8"
ListBox2.RowSource = "Tabelle6!B1:B8"
'UserForm1.Show
End Sub
Ich danke schonmal dem jenigen, der mir dabei helfen tut :o) ...vieleicht weiß ich ja auch ma was *g*
Viele Grüße
Pierre