AW: Gefilterte Zeilen/ Spalten Kopieren
11.11.2008 17:46:00
fcs
Hallo Falk,
hier mein Vorschlag inkl. Beispiel-Tabellen
https://www.herber.de/bbs/user/56683.xls
Gruß
Franz
Sub FilterKopierenZeilen()
' Kopiert Zeilen mit Wert "" in Spalte A
Dim wksQ As Worksheet, wksZ As Worksheet
Set wksQ = Worksheets("Tabelle1")
Set wksZ = Worksheets("Tabelle2")
'Spaltentitel sind in Zeile 1
Const ZeileTitel As Long = 1
Application.ScreenUpdating = False
With wksQ
If .AutoFilterMode = True Then
.Cells(ZeileTitel, 1).AutoFilter Field:=1, Criteria1:=""
' .Range(.Cells(ZeileTitel + 1, 1), .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 81)).Copy
.Range(.Rows(ZeileTitel + 1), .Rows(.Cells(.Rows.Count, 1).End(xlUp).Row)).Copy
Else
'Aktive Zelle ist ggf. außerhalb des Listenbereiches
.Activate
.Cells(ZeileTitel, 1).Select
' .Range(.Cells(ZeileTitel + 1, 1), .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 81)).Copy
.Range(.Rows(ZeileTitel + 1), .Rows(.Cells(.Rows.Count, 1).End(xlUp).Row)).Copy
End If
End With
With wksZ
'Formate kopieren
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlFormats
'Werte Kopieren
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
End With
Application.CutCopyMode = False
'Filter für Spalte 1 wieder zurücksetzen
With wksQ
.Cells(ZeileTitel, 1).AutoFilter Field:=1
End With
Application.ScreenUpdating = True
End Sub
Sub FilterKopierenSpalte_E()
Call FilterKopierenSpalte(wksQ:=Worksheets("Tabelle1"), wksZ:=Worksheets("Tabelle3"), _
SpalteQ:=5, SpalteZ:=1)
End Sub
Sub FilterKopierenSpalte_H()
Call FilterKopierenSpalte(wksQ:=Worksheets("Tabelle1"), wksZ:=Worksheets("Tabelle3"), _
SpalteQ:=8, SpalteZ:=2)
End Sub
Sub FilterKopierenSpalte(wksQ As Worksheet, wksZ As Worksheet, SpalteQ As Long, SpalteZ As Long, _
_
Optional ZeileTitel As Long = 1)
' Kopiert Spaltenwerte mit Wert "" in Spalte A
'wksQ = 'Quelltabelle mit Autofilter
'wksZ = 'Zieltabelle
'ZeileTitel = Zeile mit Spaltentitel, Standard = 1
'SpalteQ = Spalte in Quelltabelle mit Autofilter
'SpalteZ = Spalte A, Spalte in Zieltabelle
Application.ScreenUpdating = False
With wksQ
If .AutoFilterMode = True Then
.Cells(ZeileTitel, 1).AutoFilter Field:=1, Criteria1:=""
.Range(.Cells(ZeileTitel + 1, SpalteQ), _
.Cells(.Rows.Count, 1).End(xlUp).Offset(0, SpalteQ - 1)).Copy
Else
'Aktive Zelle ist ggf. außerhalb des Listenbereiches
.Activate
.Cells(ZeileTitel, 1).Select
.Range(.Cells(ZeileTitel + 1, SpalteQ), _
.Cells(.Rows.Count, 1).End(xlUp).Offset(0, SpalteQ - 1)).Copy
End If
End With
With wksZ
'Formate kopieren
.Cells(.Rows.Count, SpalteZ).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlFormats
'Werte Kopieren
.Cells(.Rows.Count, SpalteZ).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
End With
Application.CutCopyMode = False
'Filter für Spalte 1 wieder zurücksetzen
With wksQ
.Cells(ZeileTitel, 1).AutoFilter Field:=1
End With
Application.ScreenUpdating = True
End Sub