Gefilterte Daten
kurt
ich habe dieses Makro gefunden (Forum), ich möchte nur die gefilterten Daten
kopieren und in die Tabelle "Gefiltert" einfügen und zwar ab Zeile 4 !
Leider kommt Fehlermeldung:
Bei einer Makierung von nicht angrenden Zellen, ist diese Aktion nicht durchführbar.
Ich habe nur verschiedene Spalten verkleinert.
Sub SortKopie()
Dim rg1 As Range, rg2 As Range, rg3 As Range, rg4 As Range
If IstBerechtigtSchutz Then
Sheets("Gefilterte").Visible = True
Sheets("Gefilterte").Select
Range("A4").Select
ActiveSheet.Unprotect (getStrPasswort)
Sheets("L").Select
ActiveSheet.Unprotect (getStrPasswort)
If Not ActiveSheet.AutoFilterMode Then 'muß rein sonst werden nicht alle Daten _
kopiert
Range("A3:AY3").AutoFilter
End If
'alle sichtbaren Zellen im Filterbereich
'leider gehören dazu auch die Spaltenüberschriften
Set rg1 = ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
'Überschriftenzeile ermitteln
Set rg2 = rg1.Rows(1)
'alle Spaltenüberschriften rausselektieren
For Each rg3 In rg1
If Application.Intersect(rg3, rg2) Is Nothing Then
'alle Zellen zu einem neuen Bereich (rg4) zusammenfassen, _
die sich nicht in der Überschriftenzeile befinden
If rg4 Is Nothing Then
Set rg4 = rg3
Else
Set rg4 = Union(rg4, rg3)
End If
End If
Next rg3
''gefilterte Zellen selektieren
rg4.Select
rg4.Copy
Sheets("Gefilterte").Select
Range("A4").Select
ActiveSheet.Paste
Range("A2").Select
Application.CutCopyMode = False 'kopieren zurücksetzen
'alle Objektvariablen deaktivieren
Set rg1 = Nothing
Set rg2 = Nothing
Set rg3 = Nothing
Set rg4 = Nothing
Sheets("L").Select
Range("A2").Select
Else
MsgBox "Sie haben für diese Aktion keine Berechtigung ! " & Chr(13) _
& Chr(13), 48, " Hinweis !"
End If
' Application.EnableEvents = True
End Sub