AW: Auswahl mit Autofilter und verschieben
03.12.2008 11:31:00
fcs
Hallo Josef,
etwa so
Gruß
Franz
Sub FilterKopierenLoeschen()
Dim wksFilter As Worksheet, objFilter As Filter
Dim wksZiel As Worksheet
Dim lngZeile As Long, bolAlle As Boolean
Dim varAuswahl, strVerzeichnisAktuell
On Error GoTo Fehler
varAuswahl = MsgBox("Gefilterte Daten nach Tabelle2 kopieren und löschen?", _
vbYesNo + vbQuestion, "Filter-Export")
If varAuswahl = vbYes Then
Set wksFilter = ActiveSheet 'Tabellenblatt mit Autofilter
Set wksZiel = Worksheets("Tabelle2")
'Zeile der Zieltabelle ab der Daten eingefügt werden sollen
With wksZiel
lngZeile = .Cells.SpecialCells(xlCellTypeLastCell).Row + 1
End With
With wksFilter
If .AutoFilterMode = True Then
'prüfen, ob ein Filter gesetzt ist
bolAlle = True
For Each objFilter In .AutoFilter.Filters
If objFilter.On = True Then
bolAlle = False
End If
Next
If bolAlle = True Then
If MsgBox("Es wurde kein Filter gesetzt, trotzdem Kopieren und Löschen?", _
vbYesNo) = vbNo Then
GoTo Fehler
End If
End If
'Daten Kopieren
.Range(.Rows(.AutoFilter.Range.Row + 1), .Rows(.AutoFilter.Range.Row _
+ .AutoFilter.Range.Rows.Count - 1)).Copy Destination:=wksZiel.Cells(lngZeile, 1)
Application.ScreenUpdating = False
'Kopierte (sichtbare) Zeilen löschen
For lngZeile = .AutoFilter.Range.Row + .AutoFilter.Range.Rows.Count - 1 _
To .AutoFilter.Range.Row + 1 Step -1
If .Rows(lngZeile).Hidden = False Then .Rows(lngZeile).Delete Shift:=xlShiftUp
Next
Application.ScreenUpdating = True
If bolAlle = False Then .ShowAllData
End If
End With
End If
Fehler:
With Err
If Err 0 Then
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End If
End With
Set wksZiel = Nothing: Set wksFilter = Nothing
End Sub