herausgefilterte Daten noch da

Hallo zusammen,
ich habe ein kleines Makro, in dem ich aus einer Ursprungsdatei, die ich mit dem Makro auswähle, in ein Tabellenblatt kopiere. Die Ursprungsdatei schlie0e ich danach, weil ich die nicht mehr benötige und auch nicht ändern möchte. Anschließend filtere ich die Daten (Spalte A die Werte 3601, 3701, 3769).
Das funktioniert auch so weit so gut.
Wenn ich allerdings in meinem Tabellenblatt (Tabelle1) alles markiere und die Zellen lösche, erscheinen alle nicht gefilterten Sätze ab dem Feld A1.
Anbei den Code:
Code-Beginn:

Sub einlesen()
Worksheets("Tabelle1").Select
Range("a5:L" & Range("L" & Rows.Count).End(xlUp).Row).Select
Selection.ClearContents
Dim verz As String
Dim datei As String
verz = ActiveWorkbook.Path
'MsgBox verz
Dim strDateiname As String
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.InitialFileName = verz & "\*.xlsx"
If .Show = -1 Then
strDateiname = .SelectedItems(1)
End If
End With
Workbooks.Open filename:=strDateiname
datei = ActiveWorkbook.Name
'MsgBox datei
Worksheets("Übersicht").Select
Range("A14:L" & Range("L" & Rows.Count).End(xlUp).Row).Select
Selection.Copy
ThisWorkbook.Sheets(1).Range("A5").PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
' Zwischenablage löschen, da sonst Abfrage beim Schliessen der Quell-Datei
Application.CutCopyMode = False
' Schliessen der Quell-Datei
Workbooks(datei).Activate
ActiveWorkbook.Close savechanges = False
' Spaltenbreite setzen
Columns("A:A").Select
Selection.ColumnWidth = 10
Columns("B:B").Select
Selection.ColumnWidth = 30
Columns("C:C").Select
Selection.ColumnWidth = 15
Columns("D:L").Select
Selection.ColumnWidth = 20
Columns("H:H").Select
Selection.ColumnWidth = 5
'Zeilenhöhe anpassen
Cells.Select
Selection.Rows.AutoFit
' Relevante AKZ selektieren (3601, 3701, 3769)
ActiveSheet.Range("$A$5:$L$999").AutoFilter Field:=1, Criteria1:=Array("3601", "3701", "3769"),  _
Operator:=xlFilterValues
End Sub

Code-Ende
Wahrscheinlich gibt es für den Code noch gewaltiges Verbesserungspotential, aber so verstehe ich ihn und auch Kolleginnen/Kollegen, die anschließend damit arbeiten.
Viele Grüße
Günter

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub einlesen() Dim verz As String Dim datei As String Dim Zeile_L As Long 'altdaten löschen With Worksheets("Tabelle1") .Select If .AutoFilterMode = True Then If .FilterMode = True Then .ShowAllData End If Zeile_L = .UsedRange.Row + .UsedRange.Rows.Count - 1 If Zeile_L >= 5 Then .Range("a5:L" & Zeile_L).ClearContents End If End With verz = ActiveWorkbook.Path 'MsgBox verz Dim strDateiname As String With Application.FileDialog(msoFileDialogOpen) .AllowMultiSelect = False .InitialFileName = verz & "\*.xlsx" If .Show = -1 Then strDateiname = .SelectedItems(1) End If End With Workbooks.Open Filename:=strDateiname datei = ActiveWorkbook.Name 'MsgBox datei Worksheets("Übersicht").Select Range("A14:L" & Range("L" & Rows.Count).End(xlUp).Row).Copy ThisWorkbook.Sheets(1).Range("A5").PasteSpecial Paste:=xlAll, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False ' Zwischenablage löschen, da sonst Abfrage beim Schliessen der Quell-Datei Application.CutCopyMode = False ' Schliessen der Quell-Datei Workbooks(datei).Activate ActiveWorkbook.Close savechanges = False ' Spaltenbreite setzen Columns("A:A").ColumnWidth = 10 Columns("B:B").ColumnWidth = 30 Columns("C:C").ColumnWidth = 15 Columns("D:L").ColumnWidth = 20 Columns("H:H").ColumnWidth = 5 'Zeilenhöhe anpassen Cells.Rows.AutoFit ' Relevante AKZ selektieren (3601, 3701, 3769) ActiveSheet.Range("$A$5:$L$999").AutoFilter Field:=1, _ Criteria1:=Array("3601", "3701", "3769"), _ Operator:=xlFilterValues End Sub

.... Columns("H:H").Select Selection.ColumnWidth = 5 'Zeilenhöhe anpassen Cells.Select Selection.Rows.AutoFit ' Relevante AKZ selektieren (3601, 3701, 3769) Call DeleteRows(Range("A6:L999"), 1, Array(3601, 3701, 3769)) 'Bereich ohne Überschriften!!! End Sub Sub DeleteRows(rngData As Range, lngCriteriaColumn As Long, arrCriteria) Dim rngC As Range, rngDel As Range For Each rngC In rngData.Columns(lngCriteriaColumn) If IsError(Application.Match(rngC, arrCriteria, 0)) Then If rngDel Is Nothing Then Set rngDel = rngC Else Set rngDel = Union(rngDel, rngC) End If End If Next rngC If Not rngDel Is Nothing Then rngDel.EntireRow.Delete End If End Sub

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread