Makroanpassung

Question

Hallo,

mein Makro ist noch nicht funktionstüchtig.

Im Tabellenblatt 'Artikel_Report' stehen in Spalte A-L Daten. Jetzt setze ich 2 Filter:
1. Filter: alle Daten, die in Spalte L eine '1' stehen haben.
2. Filter: alle Daten, die in Spalte E eine "50" stehen haben.

Nun sollen alle Inhalte ab A2 kopiert und in das Tabellenblatt 'Aktionsplanung' in Spalte A unter die letzte beschriebene Zeile eingefügt werden.
Dann soll auf dem Tabellenblatt 'Artikel_Report' in Spalte L jede '1' entfernt werden.
Als letztes soll der Cursor im Tabellenblatt 'Aktionsplanung' in Zelle G2 stehen.

Sub Artikelauswahl_Prozent()
'
' Artikelauswahl_Prozent Makro

ActiveSheet.Range("$A$1:$L$121").AutoFilter Field:=12, Criteria1:="<>"
ActiveSheet.Range("$A$1:$L$121").AutoFilter Field:=5
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Aktionsplanung").Select
Range("A2").Select
ActiveSheet.Paste
Range("G2").Select
Sheets("Artikel_Report").Select
Application.CutCopyMode = False
Range("L2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("I123").Select
Sheets("Aktionsplanung").Select
Range("G2").Select
End Sub

Irgendwie funktioniert das Makro nicht richtig:
- die kopierten Daten stimmen nicht mit den gefilterten Daten überein
- die '1' auf dem Tabellenblatt 'Artikel_Report' in Spalte L wird nicht komplett gelöscht
- das Makro ist sehr langsam

Kann mir jemand helfen?

Gruß, Colatrinnkerr.

Answer 1

Hallo Colatrinnkerr .-)

Ein Beispiel!

Gruss Nighty

Sub AfilterCopy()
Worksheets(1).Range("E1:L1").AutoFilter
Worksheets(1).Range("E1").AutoFilter Field:=1, Criteria1:=1
Worksheets(1).Range("L1").AutoFilter Field:=8, Criteria1:=50
Worksheets(1).Rows(1).Hidden = True
Set FilteredRange = Worksheets(1).AutoFilter.Range.SpecialCells(xlCellTypeVisible)
FilteredRange.Copy Worksheets(2).Range("A" & Worksheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
Worksheets(1).Rows(1).Hidden = False
Worksheets(1).Range("E1:L1").AutoFilter
End Sub

Answer 2

Hallo Nighty,

ich habe die worksheets angepasst, aber hier bleibts hängen:

Set FilteredRange = Worksheets("Artikel_Report").AutoFilter.Range.SpecialCells(xlCellTypeVisible)

Gruß
Colatrinnkerr.

Answer 3

Hallo,

hier der Link zur Datei....das veranschaulicht mein Problem besser.

https://drive.google.com/file/d/0B_RPM6iuZmnRTXBiODhQTlRiWUk/view?usp=sharing

Gruß,
Colatrinnkerr.

Answer 4

Hallo colatrinnkerr .-)

Ich hab noch Excel 2000 *O_o*

Bite im Xls Format
Erreichbar unter SaveAs
Dann nochmal Hochladen!

Gruß Nighty

Answer 5

und hier als xls :-)

https://drive.google.com/open?id=0B_RPM6iuZmnRR0hMZkJtNE1oZWc

Answer 6

Hallo colatrinnkerr .-)

Probier mal!

Gruß Nighty

Vorraussetzung!
Gesetzter Autofilterbereich Spalte A-L oder breiter
Nach Auswahl der Kreterien,das Makro starten

Sub FilterBereich()
Dim FilteredRange As Object
Worksheets("Artikel_Report").Rows(1).Hidden = True
Set FilteredRange = Worksheets("Artikel_Report").AutoFilter.Range.SpecialCells(xlCellTypeVisible)
FilteredRange.Copy Worksheets("Aktionsplanung").Range("A" & Worksheets("Aktionsplanung").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
FilteredRange.Offset(0, 11).Clear
Worksheets("Artikel_Report").Rows(1).Hidden = False
Worksheets("Aktionsplanung").Activate
Range("G2").Activate
End Sub

Answer 7

Hallo Nighty,

dankeschön :-).

Klappt noch nicht ganz. Es kommt folgende Fehlermeldung an dieser Stelle:
FilteredRange.Copy Worksheets("Aktionsplanung").Range("A" & Worksheets("Aktionsplanung").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)

Laufzeitfehler '1004':
Leider konnte nichts eingefügt werden, da der Kopieren-Bereich und der Einfügebereich nicht die gleiche Größe haben.

Versuchen Sie, das Problem mit einem der folgenden Schritte zu lösen:
- Klicken Sie auf eine Zelle und dann auf "Einfügen".
- Wählen sie ein Rechteck von der Größe des einzufügenden Bereichs aus, und klicken Sie dann auf "Einfügen".

Gruß Colatrinnkerr.

Answer 8

Hallo colatrinnkerr .-)

Ich hatte das auch nur nachgebaut,nicht getestet!
Ich schau nochmal .-)

Gruß Nighty

Answer 9

Hallo colatrinnkerr .-)

Fehler:
Erfasung der letzten beschriebenen Zeile,Effekt produziert eine Überschreitung!

Abhilfe:
Zeilen in Worksheets("Aktionsplanung") von Zeile 28 bis ZeilenEnde säubern bzw löschen,

Eine etwas bessere Pflege der Mappe wäre wünschenswert!

Gruß Nighty

Answer 10

Hallo colatrinnkerr .-)

Wenn du nur die Werte möchtest

Gruß Nighty

Ersetze 1 Zeile!

FilteredRange.Copy Worksheets("Aktionsplanung").Range("A" & Worksheets("Aktionsplanung").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)

Durch diese 2 Zeilen!

FilteredRange.Copy
Worksheets("Aktionsplanung").Range("A" & Worksheets("Aktionsplanung").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone