gefilterte Zeilen kopieren
19.08.2020 19:39:45
Elmar
ich hab aus dem Forum hier das untere Makro bekommen, was schon echt richtig klasse ist.
Nun hab ich eine Frage an die Experten, denn irgendwie bekomme ich nicht hin, dass das Makro auch dann klappt, wenn der Autofilter nicht wie hier ab / in Zeile 1 sondern ab der Zeile 23 filtert.
Wenn der Filter in der Zeile 1 steht, klappt das Makro bestens, aber ich bräuchte es eben erst ab der Zeine 23.
Danke schon mal vorab..
VG aus Bayern
Elmar
Sub FilterBereichKopieren()
'Makro kopiert die ersten X angezeigten Zeilen in einer gefilterten Liste
'09.12.2010, NoNet - www.excelei.de
Dim lngLZ As Long, lngAnzahl As Long
Dim rngF As Range, rngZ As Range
lngAnzahl = 20 'nur die ersten 20 gefilterten Werte (inkl.Überschrift) kopieren
Set rngF = Intersect(ActiveSheet.AutoFilter.Range, Columns("A:A")).SpecialCells( _
xlCellTypeVisible)
For Each rngZ In rngF
lngLZ = lngLZ + 1
If lngLZ > lngAnzahl Then 'Schleife nur bis zur angegebenen Anzahl
lngLZ = rngZ.Row
Exit For 'sehr unelegant, in einer FOR...EACH-Schleife jedoch nicht anders lö _
sbar !
End If
Next
'Spalten A:J kopieren :
Intersect(ActiveSheet.AutoFilter.Range.Resize(lngLZ - ActiveSheet.AutoFilter.Range.Row + 1), _
_
_
_
Columns("A:J")).Copy
'Neues Blatt einfügen und dort die kopierten Daten der gefilterten Liste einfügen :
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Bild1"
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("A:A").ColumnWidth = 13.71
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").ColumnWidth = 32.86
Columns("H:H").ColumnWidth = 15.43
Columns("I:I").ColumnWidth = 16.14
Columns("J:J").ColumnWidth = 15.29
Rows("1:1").Select
Range("A1:J21").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Bilder").Select
Range("A45").Select
ActiveSheet.Pictures.Paste.Select
Dim objpic As Object
For Each objpic In ActiveSheet.Pictures
With objpic.ShapeRange
.LockAspectRatio = False
.Height = Application.CentimetersToPoints(9.51)
.Width = Application.CentimetersToPoints(20.01)
End With
Next
Sheets("Bild1").Select
Application.DisplayAlerts = False
Sheets("Bild1").Delete
Application.DisplayAlerts = True
End Sub
