Im DropDown Feld gelistete Kriterien abarbeiten

Hallo Excel-Gemeinde,
meine VBA-Kenntnisse sind fast null. Ich kann recht gut mit dem Makrorecorder umgehen und habe damit mein Problem annähernd gelöst. Ich setze einen Autofilter für mehrere Spalten und filtere dann eine Spalte nach einem der vielen im Drop Down Feld angezeigten Kriterium. Die dann angezeigten Werte kopiere ich in ein separates Arbeitsblatt. Da ich das für jedes Kriterium im Drop Down Feld machen muß, sollte es so sein, dass die Kriterien im Drop Down Feld automatisch nacheinander abgearbeitet werden.
Gibt es für die Stelle im Code "Criteria1:=_
"Spielereinsätze"
eine Anweisung die oben geschildertes Problem löst?
Für Eure Bemühungen schon mal ein dickes Danke!
Der mit dem Makrorecorder aufgezeichnete Code sieht so aus:
ActiveCell.Offset(1, 0).Range("A1").Select
Sheets("Spielername").Select
ActiveSheet.ShowAllData
ActiveCell.Offset(-1, 0).Range("A1").Select
Cells.Find(What:="Spielerdetails", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
ActiveSheet.Range("$A$1:$R$8611").AutoFilter Field:=7, Criteria1:= _
"Spielereinsätze"
ActiveCell.Offset(4, 7).Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Tabelle1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.Offset(-1, 1).Range("A1").Select

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub aaaTest() Dim wksSpieler As Worksheet, wksZiel As Worksheet, Zeile As Long Dim oCollection As New Collection, iI As Long Set wksSpieler = Sheets("Spielername") Set wksZiel = Sheets("Tabelle1") On Error GoTo Fehler ActiveCell.Offset(1, 0).Range("A1").Select With wksSpieler .Activate Application.ScreenUpdating = False If .FilterMode = True Then ActiveSheet.ShowAllData 'Einblenden aller Datenzeilen 'Alle verschiedenen sichtbaren Werte in Spalte 7 ab Zeile 2 einmal erfassen For Zeile = 2 To .Cells.SpecialCells(xlCellTypeLastCell).Row If .Cells(Zeile, 7).EntireRow.Hidden = False Then oCollection.Add Item:=.Cells(Zeile, 7).Value, Key:=.Cells(Zeile, 7).Text End If Next 'Filterwerte setzen und gefundene Daten kopieren For iI = 1 To oCollection.Count 'Filter in Spalte 7 setzen .Range("$A$1:$R$8611").AutoFilter Field:=7, Criteria1:= _ oCollection.Item(iI) If .Cells(.Rows.Count, 7).End(xlUp).Row >= 2 Then 'gefilterte Werte in Spalte 7 kopieren .Range(.Cells(2, 7), .Cells(.Rows.Count, 7).End(xlUp)).Copy With wksZiel 'Werte + Formate in Spalte 1 (A) nach letzter gefüllter Zeile einfügen With .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0) .PasteSpecial Paste:=xlFormats .PasteSpecial Paste:=xlValues End With Application.CutCopyMode = False End With End If Next End With wksZiel.Activate Fehler: With Err Select Case .Number Case 0 'Alles OK Case 457 'Collection soll Item ein 2. MAl hinzugefügt werden Resume Next Case Else MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _ vbInformation + vbOKOnly, "Makro - Autofilter-Auswertung" End Select End With Application.ScreenUpdating = True End Sub

Hallo Klaus,
hier mein Vorschlag, wie du das Makro etwa anpassen müsstest, um die Filterwerte in Spalten nebeneinander zu kopieren.
Gruß
Franz

Sub aaaTest()
Dim wksSpieler As Worksheet, wksZiel As Worksheet, Zeile As Long
Dim oCollection As New Collection, iI As Long, Spalte As Long
Set wksSpieler = Sheets("Spielername")
Set wksZiel = Sheets("Tabelle1")
On Error GoTo Fehler
ActiveCell.Offset(1, 0).Range("A1").Select
With wksZiel
'Altdaten löschen
.UsedRange.Clear
Spalte = 1 '1. Spalte im Zielblatt, in die Daten kopiert werden sollen
End With
With wksSpieler
.Activate
Application.ScreenUpdating = False
If .FilterMode = True Then ActiveSheet.ShowAllData 'Einblenden aller Datenzeilen
'Alle verschiedenen sichtbaren Werte in Spalte 7 ab Zeile 2 einmal erfassen
For Zeile = 2 To .Cells.SpecialCells(xlCellTypeLastCell).Row
If .Cells(Zeile, 7).EntireRow.Hidden = False Then
oCollection.Add Item:=.Cells(Zeile, 7).Value, Key:=.Cells(Zeile, 7).Text
End If
Next
'Filterwerte setzen und gefundene Daten kopieren
For iI = 1 To oCollection.Count
'Filter in Spalte 7 setzen
.Range("$A$1:$R$8611").AutoFilter Field:=7, Criteria1:= _
oCollection.Item(iI)
If .Cells(.Rows.Count, 7).End(xlUp).Row >= 2 Then
'Filterwert in Zeile 1 eintragen
wksZiel.Cells(1, Spalte).Value = oCollection.Item(iI)
'gefilterte Werte in Spalte 2 kopieren
.Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp)).Copy
'Werte + Formate in Spalte ab Zeile 2 einfügen
With wksZiel
With .Cells(2, Spalte)
.PasteSpecial Paste:=xlFormats
.PasteSpecial Paste:=xlValues
End With
End With
'gefilterte Werte in Spalte 14 kopieren
.Range(.Cells(2, 14), .Cells(.Rows.Count, 14).End(xlUp)).Copy
'Werte + Formate in Spalte+1 ab Zeile 2 einfügen
With wksZiel
With .Cells(2, Spalte + 1)
.PasteSpecial Paste:=xlFormats
.PasteSpecial Paste:=xlValues
End With
Application.CutCopyMode = False
'Nachste Einfüge-Spalte
Spalte = Spalte + 2
If Spalte >= .Columns.Count Then
MsgBox "Im Zieltabellenblatt können keine weiteren Daten eingefügt werden!"
End If
End With
End If
Next
End With
wksZiel.Activate
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case 457 'Collection soll Item ein 2. MAl hinzugefügt werden
Resume Next
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
vbInformation + vbOKOnly, "Makro - Autofilter-Auswertung"
End Select
End With
Application.ScreenUpdating = True
End Sub

Beliebteste Forumthreads (12 Monate)

Im DropDown Feld gelistete Kriterien abarbeiten

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

331 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Im DropDown Feld gelistete Kriterien abarbeiten

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

331 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread