Schleife wird gegen Ende immer langsamer

Guten Morgen allerseits.
Ich habe ein Tabellenblatt "Angebot", das in den Spalten C-I Text enthält, davon sind 300 verbundene Zellen. Die Zellverbünde sind alle einzeilig. In manchen dieser Verbundzellen sind (variable) längere Texte enthalten, die nicht vollständig angezeigt werden, wenn man die Zeilen nur mit "Start > Zellen > Format > Zeilenhöhe automatisch anpassen" auf optimale Höhe bringen will.
Zu diesem Zweck habe ich ein Makro (Button "Zeilenhöhe anpassen"), das in einer Schleife alle Zellen in den Spalten C-I durchgeht und bei Zellverbünden (MergeArea) die Zeilenhöhe anpasst. Das Makro bearbeitet die jeweils markierten Zellen im UsedRange. Daher müssen zum Start des Makros die Spalten C-I markiert sein.
Funktioniert prima, aber ab ca. Zellverbund Nummer 200 wird das Makro deutlich und zunehmend langsamer. Zu Beginn braucht es ca. 1/10 Sekunde pro Zellverbund, bei Nummer 300 dann ca. 7 Sekunden. Ich habe zu diesem Zweck einen Zeitmesser eingebaut, der mir nach jeweils 20 Verbundzellen die Zeit misst. Diese Rundenzeiten werden am Ende in Spalte V ausgegeben (früher gemessene Rundenzeiten werden nach rechts verschoben).
Interessant ist auch, dass das Makro immer unterschiedlich lange braucht, obwohl alle Parameter immer identisch sind und sonst nix auf dem Computer läuft.
Irgendwo läuft da ein Speicher voll.
Musterdatei: https://www.herber.de/bbs/user/156637.xlsm
Hier ist eine weitere Excel-Datei, in der ich den ganzen Makro-Code ausgelesen habe, was die Übersicht erleichtert: https://www.herber.de/bbs/user/156638.xlsm
Ich verwende in der Firma Office 365 (lokale Installation) (=blaue Rundenzeiten) und habe es zuhause auf meinem über 6 Jahre alten Rechner mit Office 2013 laufen lassen, wo es insgesamt schneller, aber auch ab 200 langsamer läuft (=rote Rundenzeiten). Ich meine, dass dieses Problem früher mit Office 2010 nicht aufgetreten ist; das steht mir aber nicht mehr zur Verfügung. Zumindest sind alle meine komplexen Makros mit 2010 viel schneller gelaufen als mit 365. Und auch seltener eingefroren.
Wer weiß, was das ist und vor allem, was man dagegen tun kann?
Bei Hinweisen, die zur Festnahme und Verurteilung des Verdächtigen führen, winken beste Nürnberger Lebkuchen.
Off Topic:
Ein vermutlich damit zusammenhängendes Problem habe ich wenn ich (in einem anderen Fall) zwei lange Makros nacheinander von einem Master-Makro aus aufrufe. Das zweite geht in Schleife alle Zeilen der Tabelle durch, prüft sie und modifiziert sie ggf. Irgendwann heißt es dann "Nicht genügend Speicher vorhanden". Wenn man OK drückt, läuft das Makro trotzdem noch viele Zeilen weiter und sagt dann wieder "Nicht genügend Speicher vorhanden". Das könnte man theoretisch bis zum Ende der Tabelle wiederholen und hätte das gewünschte Ergebnis. Das würde aber ewig dauern.
Wenn ich die beiden Makros nacheinander von Hand anstoße, kommt die Fehlermeldung auch. Wenn ich Excel (ganze Applikation) aber schließe und die Datei neu aufrufe, läuft das zweite Makro problemlos durch (möglicherweise gegen Ende auch langsamer, was ich aber bisher nicht nachgemessen habe).
Irgendwo läuft da ein Speicher voll. Es ist übrigens das Makro, das in der zweiten Datei den Code farblich formatiert.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

#1: wusste ich nicht, ist aber irgendwie plausibel, denn manuell mach ich das auch so, weil das Auge da besser vorerfassen kann, wer als nächstes kommt.
#2: versteh ich nicht ganz, aber mit SpecialCells arbeite ich bequemlichkeitshalber, wenn ich sie brauche.
#3: das hab ich schon probiert. Das geht natürlich irre schnell. So schnell, dass man keine echten Rundenmessungen machen kann. Aber das setzt voraus, dass die Soll-Höhen bekannt sind. Es gibt aber auch einige Zeilen mit variabler Höhe. Im Prinzip kann jede Höhe geändert werden. Und für den Anwender ist es nicht leistbar, bei fast 400 Zeilen optisch herauszufinden, ob eine Zeile möglicherweise nicht vollständig zu sehen ist.
Daher muss ich eigentlich schon grundsätzlich alle Zellen einzaln nach Bedarf anpassen.
#4: in Einzelzellen auflösen geht nicht. Es ist variabler Fließtext. Manche, die definitiv nie eine Zeile überschreiten, könnte ich als Einzelzellen führen, aber das sind nicht besonders viele.
Ich könnte die Zeit also durchaus noch reduzieren, es bleibt aber die grundsätzliche Frage, warum eine Schleife mit der Zeit immer langsamer läuft. Wo läuft da ein Speicher voll und wie kann man ihn im laufenden Prozess leeren?

Sub Makro1() Dim TF As Shape Dim ZHalt As Double, ZHneu Dim Zelle As Range Dim Bereich As Range Dim z As Long Dim zEnde As Long Dim zStart As Long With ActiveSheet.UsedRange zStart = 2 zEnde = .Rows.Count .EntireRow.AutoFit End With '--- Textfeld für Zeilenhöhenermittlung erstellen und einrichten Set TF = ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, 1, 1, 10, 10) With TF.TextFrame2 .MarginLeft = 1 .MarginTop = 1 .MarginRight = 1 .MarginBottom = 1 End With '--- Zeilenhöhe ermitteln For z = zStart To zEnde ZHalt = Rows(z).RowHeight ZHneu = ZHalt Application.StatusBar = "Zeilenhöhen ermitteln Zeile " & z & " von " & zEnde For Each Zelle In Intersect(Range("C:I"), Rows(z)).Cells If Zelle.Value "" Then 'Zelle nicht leer With TF.TextFrame2.TextRange .Font.Size = Zelle.Font.Size .Characters.Text = Zelle.Value End With TF.Width = Zelle.MergeArea.Width TF.TextFrame2.AutoSize = msoAutoSizeShapeToFitText If ZHneu ZHalt Then Rows(z).RowHeight = ZHneu Next TF.Delete Application.StatusBar = False End Sub

Sub Zeilenhoehe_ueber_Textfeld() ' ----- Makro von Daniel im Herber-Forum ' (https://www.herber.de/forum/cgi-bin/f_each.pl?idx=1910748) ' --- Info -------------------------------------------------------------------------------- ' Update: 09.12.2022 ' Dieses Makro stellt bei verbundenen Zellen in EINER Zeile die optimale Höhe ein, ' was mit AutoFit nicht funktionieren würde. Dim TF As Shape Dim ZHalt As Double, ZHneu As Double Dim Zelle As Range, VerbundZelle As Range Dim z As Long Dim zEnde As Long Dim zStart As Long Dim strikes As Integer, SchriftGroesse As Variant, Faktor As Double strikes = 0 NochmalEingeben_1: SchriftGroesse = InputBox(vbCr & vbCr & "Welches ist die ""normale"" Schriftgröße in diesem Blatt?" & vbCr & "", "Variable als Zahl anlegen") If strikes >= 2 Then ' wenn der Zähler 2 ist, wird das Makro abgebrochen MsgBox " Makro wird abgebrochen, du Honk, weil du nicht bis " & ActiveCell.Font.Size & " zählen kannst!" & _ vbCr & vbCr & _ "________________________________________________" Exit Sub Else If IsNumeric(SchriftGroesse) Then GoTo LosGehts_1 Else strikes = strikes + 1 ' wenn keine Schriftgröße eingegeben wurde, wird der Zähler um 1 hochgezählt MsgBox " Es muss eine ZAHL eingegeben werden." _ & vbCr & vbCr _ & "________________________________________________" GoTo NochmalEingeben_1 ' wenn der Zähler unter 2 ist, springt das Makro nochmal zur Eingabemaske End If End If LosGehts_1: ' --- Textfeld für Zeilenhöhenermittlung erstellen und einrichten Set TF = ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, 1, 1, 10, 10) With ActiveSheet.UsedRange zStart = 2 zEnde = .Rows.Count .EntireRow.AutoFit End With With TF.TextFrame2 .MarginLeft = 1 .MarginTop = 1 .MarginRight = 1 .MarginBottom = 1 End With Application.ScreenUpdating = False ' --- Zeilenhöhe ermitteln For z = zStart To zEnde ZHalt = Rows(z).RowHeight ZHneu = ZHalt Application.StatusBar = "Zeilenhöhen ermitteln Zeile " & z & " von " & zEnde For Each Zelle In Intersect(Range("C:I"), Rows(z)).Cells ' Zelle.Select If Zelle.MergeCells = True Then If Zelle = Zelle.MergeArea(1) Then If Zelle.Value "" Then ' Zelle nicht leer Set VerbundZelle = Zelle With TF.TextFrame2.TextRange .Font.Name = Zelle.Font.Name .Font.Size = Zelle.Font.Size .Characters.Text = Zelle.Value End With TF.Width = Zelle.MergeArea.Width TF.TextFrame2.AutoSize = msoAutoSizeShapeToFitText If ZHneu ZHalt Then ' Rows(z).RowHeight = ZHneu ' für Schrift in angegebener Normalgröße (SchriftGroesse) If Len(VerbundZelle) > 500 Then Faktor = (1 + (SchriftGroesse + 1 - VerbundZelle(1).Font.Size) / 10) Else Faktor = (1 + (SchriftGroesse + 1 - VerbundZelle(1).Font.Size) / 2 / 10) End If Rows(z).RowHeight = ZHneu * Faktor ' Angleichung für kleine Schriftgröße (z.B. Arial 6) End If Next TF.Delete Application.ScreenUpdating = True MsgBox " Feddisch " Application.StatusBar = False End Sub

Beliebteste Forumthreads (12 Monate)

Schleife wird gegen Ende immer langsamer

24
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Schleife wird gegen Ende immer langsamer

24 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

24
Beiträge zum Forumthread

Beiträge zu diesem Forumthread