warum dauert Zeilen löschen 10 Sek.?

Hallo,

ich hoffe ihr habt einen Rat was ich noch probieren könnte. Ich und auch Chatgpt sind mit unserem Latein am Ende.

Das Problem in meinem Blatt Codes! dauert das Löschen von Zeilen ca. 10 Sek. während das Berechnen von Formeln eine Sache von Sekundenbruchteilen ist.
In der ganzen Mappe gibt es nur 4 Formeln, alle im Blatt Codes,

in K1: =ANZAHL2(D:D), in K2: =ANZAHL2(E:E)

in F1:F88326 =WENN(E1>"";AUFRUNDEN(RANG.GLEICH(E1;E$1:INDEX(E:E;$K$1);0)/$K$2;2);"")

und in H1:H88326 =WENN(D1>"";"http://web.archive.org/web/20220630000000/https://www.imdb.com/name/" & D1 & "/";"")

Es gibt keine Worksheet Change Makros, die sich auf das Blatt auswirken und keine bedingten Formatierungen.

Was habe ich bereits getan?

das am Ende stehende Makro laufen lassen, um eventuell unnötige Formatierungen ect. zu entfernen
geprüft, mit Strg+Ende wo sich der genutze Bereich befindet (endet bei K88326)
die Inhalte des Blatts als Werte in eine neue Mappe eingefügt (dann klppt das mit dem Löschen)
eine Kopie des Blatts in einer neuen Mappe erstellt (dann geht das Löschen etwas schneller)

Wenn mir jemand sagen kann, wie ich diese Ausmaße auf 300 KB schrumpfen kann, ohne die vermeintliche Fehlerquelle zu entfernen, mache ich das gerne und lade dann auch gerne eine Bsp Datei hoch.

hier das Makro:

Sub BereinigeCodesBlatt()

    Dim ws As Worksheet

    Dim lastRow As Long, lastCol As Long

    Dim rngKeep As Range

    Dim shp As Shape

    Dim cmt As Comment

    Dim area As Range

    

    Set ws = ThisWorkbook.Sheets("Codes")

    

    ' --- Bereiche, die behalten werden ---

    Set rngKeep = Union(ws.Range("A1:I88326"), ws.Range("K1:K2"))

    

    Application.ScreenUpdating = False

    Application.Calculation = xlCalculationManual

    

    ' --- 1. Inhalte und Formate außerhalb der behaltenen Bereiche löschen ---

    ws.Cells.ClearFormats

    ws.Cells.ClearContents

    

    ' Inhalte/Formate in den behaltenen Bereichen wiederherstellen

    For Each area In rngKeep.Areas

        area.Value = area.Value

        area.NumberFormat = "General"

    Next area

    

    ' --- 2. Objekte (Shapes, Textfelder, Bilder) außerhalb des behaltenen Bereichs löschen ---

    For Each shp In ws.Shapes

        If Intersect(shp.TopLeftCell, rngKeep) Is Nothing Then

            shp.Delete

        End If

    Next shp

    

    ' --- 3. Kommentare/Notizen außerhalb des behaltenen Bereichs löschen ---

    For Each cmt In ws.Comments

        If Intersect(cmt.Parent, rngKeep) Is Nothing Then

            cmt.Delete

        End If

    Next cmt

    

    ' --- 4. Alte Zeilen/Spalten außerhalb löschen ---

    On Error Resume Next

    lastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    lastCol = ws.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

    On Error GoTo 0

    

    If lastRow > 88326 Then ws.Rows("88327:" & lastRow).Delete

    If lastCol > 11 Then ws.Columns("L:" & ws.Columns(lastCol).Address(False, False)).Delete

    

    Application.Calculation = xlCalculationAutomatic

    Application.ScreenUpdating = True

    

    MsgBox "Bereinigung abgeschlossen!", vbInformation

End Sub

Hallo Case,

sorry nochmal für die Namensverwechslung gerade.

Also prinzipiell hat dein Makro funktioniert, ich habe trotzdem noch ein paar Sachen geändert.

1. noch mehr deaktiviert, nicht weil es notwendig war, sondern um eine einheitliche Struktur mit den anderen Makros in der Mappe zu haben.
2. Ausgabe in Spalte F statt H
3. Variablen einen für mich nachvollziehbaren Namen gegeben.
4. Den Code und das Worksheet Change Event zusammengefasst (aus demselben Grund, Vereinheitlichung mit den anderen Makros).

Dann habe ich leider festgestellt, dass das Zeilen löschen immer noch sehr lange dauert, also hab ich mich mal noch der anderen Formel in Spalte H gewidmet, diese durch Werte ersetzt und siehe da dann war Löschen just in Time möglich.
Dann hab ich mir überlegt, wie ich das Problem löse und hab mir gedacht, warum dann nicht noch ein zweites Worksheet Change, dass auf Eingabe in Spalte D reagiert und in derselben zeile Spalte H berechnet.
Und raus kam dann dieses Makro, was alle meine Tests bestanden hat und zulässt dass Zeilen in 0, nichts gelöscht werden. Vielen Dank für eure Unterstützung
Christian

Option Explicit



Private Sub Worksheet_Change(ByVal Target As Range)

    Dim Zeile As Long

    Dim AnzahlGueltigerDaten As Long

    Dim Ausgabearray() As Variant

    Dim DatumArray() As Double

    Dim Eingabearray As Variant

    Dim RangDict As Object

    Dim LetztesDatum As Double

    Dim DatumSchluessel As String

    Dim GesamtZeilen As Long

    Dim AktuelleZeile As Long

    

    ' --- Alles deaktivieren für Performance ---

    With Application

        .ScreenUpdating = False

        .Calculation = xlCalculationManual

        .EnableEvents = False

        .DisplayAlerts = False

    End With

    

    On Error GoTo Cleanup ' sicherstellen, dass alles wieder eingeschaltet wird



    ' --- Abschnitt für Spalte E (Datumsrangberechnung) ---

    If Not Intersect(Target, Me.Columns("E")) Is Nothing Then

        ' Alle Werte aus Spalte E bis letzte gefüllte Zeile einlesen

        Eingabearray = Me.Range("E1:E" & Me.Cells(Me.Rows.Count, 5).End(xlUp).Row).Value

        GesamtZeilen = UBound(Eingabearray, 1)

        

        ' Nur gültige Datumswerte in ein Array übernehmen

        AnzahlGueltigerDaten = 0

        For AktuelleZeile = 1 To GesamtZeilen

            If IsDate(Eingabearray(AktuelleZeile, 1)) Then

                AnzahlGueltigerDaten = AnzahlGueltigerDaten + 1

                ReDim Preserve DatumArray(1 To AnzahlGueltigerDaten)

                DatumArray(AnzahlGueltigerDaten) = CDbl(Eingabearray(AktuelleZeile, 1))

            End If

        Next AktuelleZeile

        

        ' Wenn keine Datumswerte vorhanden, überspringen

        If AnzahlGueltigerDaten > 0 Then

            ' QuickSort, absteigend (jüngste zuerst)

            QuickSortDatum DatumArray, 1, AnzahlGueltigerDaten

            

            ' Dictionary zur Speicherung von Datum -> Rang

            Set RangDict = CreateObject("Scripting.Dictionary")

            

            Dim RangZaehler As Long

            RangZaehler = 1

            

            For AktuelleZeile = 1 To AnzahlGueltigerDaten

                If AktuelleZeile = 1 Or DatumArray(AktuelleZeile) > LetztesDatum Then

                    RangZaehler = AktuelleZeile

                End If

                If Not RangDict.Exists(CStr(DatumArray(AktuelleZeile))) Then

                    RangDict.Add CStr(DatumArray(AktuelleZeile)), RangZaehler

                End If

                LetztesDatum = DatumArray(AktuelleZeile)

            Next AktuelleZeile

            

            ' Ausgabearray für Spalte F vorbereiten

            ReDim Ausgabearray(1 To GesamtZeilen, 1 To 1)

            

            For AktuelleZeile = 1 To GesamtZeilen

                If IsDate(Eingabearray(AktuelleZeile, 1)) Then

                    DatumSchluessel = CStr(CDbl(Eingabearray(AktuelleZeile, 1)))

                    Ausgabearray(AktuelleZeile, 1) = WorksheetFunction.RoundUp(RangDict(DatumSchluessel) / AnzahlGueltigerDaten, 2)

                Else

                    Ausgabearray(AktuelleZeile, 1) = ""

                End If

            Next AktuelleZeile

            

            ' Ergebnis in Spalte F schreiben und formatieren

            Me.Range("F1").Resize(GesamtZeilen, 1).Value = Ausgabearray

            Me.Range("F1").Resize(GesamtZeilen, 1).NumberFormat = "0%"

        End If

    End If



    ' --- Abschnitt für Spalte D (URL einfügen in Spalte H) ---

    If Not Intersect(Target, Me.Columns("D")) Is Nothing Then

        Dim Zelle As Range

        For Each Zelle In Intersect(Target, Me.Columns("D"))

            If Zelle.Value > "" Then

                ' URL zusammensetzen

                Me.Cells(Zelle.Row, "H").Value = "http://web.archive.org/web/20220630000000/https://www.imdb.com/name/" & Zelle.Value & "/"

            Else

                Me.Cells(Zelle.Row, "H").ClearContents

            End If

        Next Zelle

    End If



Cleanup:

    ' --- Alles wieder einschalten ---

    With Application

        .ScreenUpdating = True

        .Calculation = xlCalculationAutomatic

        .EnableEvents = True

        .DisplayAlerts = True

    End With

End Sub



'------------------------------

' QuickSort für Double-Array (absteigend)

Private Sub QuickSortDatum(ByRef arr() As Double, ByVal IndexUnten As Long, ByVal IndexOben As Long)

    Dim PivotWert As Double

    Dim TempWert As Double

    Dim Links As Long

    Dim Rechts As Long

    

    Links = IndexUnten

    Rechts = IndexOben

    PivotWert = arr((IndexUnten + IndexOben) \ 2)

    

    Do While Links = Rechts

        Do While arr(Links) > PivotWert

            Links = Links + 1

        Loop

        Do While arr(Rechts)  PivotWert

            Rechts = Rechts - 1

        Loop

        If Links = Rechts Then

            TempWert = arr(Links)

            arr(Links) = arr(Rechts)

            arr(Rechts) = TempWert

            Links = Links + 1

            Rechts = Rechts - 1

        End If

    Loop

    

    If IndexUnten  Rechts Then QuickSortDatum arr, IndexUnten, Rechts

    If Links  IndexOben Then QuickSortDatum arr, Links, IndexOben

End Sub

warum dauert Zeilen löschen 10 Sek.?

Forumthread: warum dauert Zeilen löschen 10 Sek.?

37
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

warum dauert Zeilen löschen 10 Sek.?

Forumthread: warum dauert Zeilen löschen 10 Sek.?

37 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

37
Beiträge zum Forumthread

Beiträge zu diesem Forumthread