AW: Excel/Makro Kopie
25.07.2017 20:34:30
fcs
Hallo Fredde,
der "einfachste" Weg ist, das komplette Blatt kopieren und dann die Filteraktionen ausführen.
Dann braucht man sich nach dem Kopieren um Formatierungen nicht mehr kümmern.
Ich hab dir mal 2 Varianten angehängt.
Insbesondere bei vielen Zeilen ist der Autofilter der effektivere Weg.
LG
Franz
Sub Daten_Kopieren_Filtern()
'Verwendung des Autofilters
Dim wks As Worksheet
Dim Zei_T As Long
Dim Zei_L As Long
Dim wksCopy As Worksheet
Dim bolAutofilter As Boolean
Set wks = ActiveWorkbook.Worksheets(1) 'oder Worksheets("Tabelle1")
wks.Copy after:=wks
Set wksCopy = ActiveSheet
Application.ScreenUpdating = False
With wksCopy
.Name = "Tab " & Format(Now, "YYYY-MM-DD hh_mm_ss")
Zei_T = 2 'Zeile mit Spaltentiteln über den Daten
'Prüfen, ob Autofilter aktiv
If .FilterMode = True Then
bolAutofilter = True
.ShowAllData
End If
'letzte benutzte Zeile
Zei_L = .UsedRange.Row + .UsedRange.Rows.Count - 1
If Zei_L >= 3 Then
'Filterin Spalte E setzen
.Range(.Rows(Zei_T), .Rows(Zei_L)).AutoFilter Field:=5, Criteria1:="Equities"
'in Spalte E die sichtbaren Zellen markieren und die Zeilen löschen
With .Range(.Cells(Zei_T + 1, 5), .Cells(Zei_L, 5))
On Error Resume Next
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
Err.Clear
End With
'alle Daten anzeigen
.ShowAllData
If bolAutofilter = False Then .AutoFilterMode = False
Else
MsgBox "keine Daten vorhanden"
End If
End With
Application.ScreenUpdating = True
End Sub
Sub Daten_Kopieren_Filtern_Variante()
'Löschen der abweichenden Inhalte in den Zellen Spalte E
Dim wks As Worksheet
Dim Zei
Dim Zei_1 As Long
Dim Zei_L As Long
Dim wksCopy As Worksheet
Set wks = ActiveWorkbook.Worksheets(1) 'oder Worksheets("Tabelle1")
wks.Copy after:=wks
Set wksCopy = ActiveSheet
Application.ScreenUpdating = False
With wksCopy
.Name = "Tab " & Format(Now, "YYYY-MM-DD hh_mm_ss")
Zei_1 = 3 '1 Zeile mit Daten
'Wenn Filtermodus aktiv, dann alle Daten
If .FilterMode = True Then
.ShowAllData
End If
'letzte benutzte Zeile
Zei_L = .UsedRange.Row + .UsedRange.Rows.Count - 1
For Zei = Zei_1 To Zei_L
'in Spalte E Werte verschieden von "Equities" löschen
If .Cells(Zei, 5).Value "Equities" Then .Cells(Zei, 5).ClearContents
Next Zei
'in Spalte E die sichtbaren Zellen markieren und die Zeilen löschen
With .Range(.Cells(Zei_1, 5), .Cells(Zei_L, 5))
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Err.Clear
End With
End With
Application.ScreenUpdating = True
End Sub