gefiltertes kopieren verbessern
25.01.2022 13:51:08
Abdullah
ich habe da einen kleinen Codeabschnitt und bitte um Ratschläge, damit er schneller und besser funktioniert.
dieser Abschnitt hat die Aufgabe: Daten nach Criterial D(String) zu filtern. nachher selektiert er die sichtbare Rows und fügt sie woanders ein.
Ein Problem taucht auf : wenn nach einem Keriterium gefiltert wird, wofür keine Daten im Sheet gibt. An diesem Punkt werden alle leeren Zeilen selektiert und kopiert.
dieses Selektieren und kopieren dauert ewig lang und ich kann nicht solange warten, weil dieser Fall viel oft vorkommt. Im beispiel dauert es nicht lang, weil die Datensätze nicht so groß sind. Beispiel dient nur zur Verdeutlichung.
Hat jemand einen Rat?
https://www.herber.de/bbs/user/150651.xlsx
Sub Beispiel()
Dim i As Double
Dim D As String
Dim S As String
Dim ws As Worksheet
Sheets("Criterial").Select
For i = 2 To 8 '
D = Worksheets("Criterial").Cells(i, 1).Value
Workbooks.Add.SaveAs Filename:=Sheets("Criterial").Cells(1, 9).Value & D, FileFormat:=xlOpenXMLWorkbook
ThisWorkbook.Activate
For Each ws In Worksheets
If ws.Name "Criterial" Then
ws.Select
S = ws.Name
ws.Range("A1").AutoFilter Field:=4, Criteria1:=D
Selection.CurrentRegion.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Workbooks(D).Activate
Sheets.Add(After:=Sheets(Sheets.Count)).Name = D & "-" & S
Workbooks(D).Activate
Sheets(D & "-" & S).Range("A1").PasteSpecial
Rows("1:1").Select
Selection.ClearContents
ThisWorkbook.Activate
ws.Range("A1").AutoFilter
End If
Next ws
Workbooks(D).Save
Workbooks(D).Close
Next i
ThisWorkbook.Activate
Sheets("Criterial").Select
End Sub
Anzeige
