Anzeige
Archiv - Navigation
1212to1216
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Im DropDown Feld gelistete Kriterien abarbeiten

Im DropDown Feld gelistete Kriterien abarbeiten
Klaus
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

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

Betreff
Benutzer
Anzeige
AW: Im DropDown Feld gelistete Kriterien abarbeiten
23.05.2011 13:39:05
fcs
Hallo Klaus,
leider sind die verschiedenen Zellselektionen und Offsets für mich nicht nachvollziehbar.
Im Prinzip kann man wie folgt einen Autofilter alle vorhandenen Werte in einer Spalte durchlaufen lassen.
Gruß
Franz
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

Anzeige
AW: Im DropDown Feld gelistete Kriterien abarbeiten
23.05.2011 17:29:02
Klaus
Hallo Franz,
Das ist die Bombe!
Vielen Dank für die Riesenarbeit, die Du dir gemacht hast. Mit soviel Aufwand habe ich nicht gerechnet.
Grundsätzlich verstehe ich als Makro User nicht wirklich was Du da gebaut hast, aber es funktioniert grundsätzlich so, wie ich es mir vorgestellt habe.
2 Dinge sollten anders sein: 1. der Filter wird zwar in Spalte 7 gesetzt, aber die eigentlichen Werte stehen in Spalte 14 und 2. die gefilterten Werte sollen nicht in einer Spalte untereinander angeordnet werden, sondern jedes neue Filterergebnis in eine separate Spalte (nebeneinander) - aber das könnte ich durch deine super geschaffene Basis hinkriegen.
Anzeige
AW: Im DropDown Feld gelistete Kriterien abarbeiten
23.05.2011 18:44:44
fcs
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

Anzeige
AW: Im DropDown Feld gelistete Kriterien abarbeiten
24.05.2011 16:23:02
Klaus
Hallo Franz,
nochmal ein dickes Danke. Es funktioniert genauso wie ich es mir vorgestellt habe.
Ich habe mich da bei meiner "Bastelei" an deiner vorherigen Version mehr als schwer getan.

331 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige