Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1272to1276
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Laufzeit >5Minuten für kleines VBA Script

Laufzeit >5Minuten für kleines VBA Script
Andy
Hallo VBA´ler,
ich habe hier auf den Herber Seiten ein Script zum Optimieren der Zeilenhöhe von gebunden Zellen gefunden. Das Script läuft soweit. Jedoch benötigt es für die Änderung von etwa 30 Zellen eine Laufzeit von etwa 5 Minuten...
Kann das richtig sein?
bei "Range("AJ68:AT68").Select" handelt es sich zum Beispiel um eine verbunden Zelle.
hier mein Code, kann man diesen irgendwie schneller machen?

Sub Zeilenhöhe_gebundene_Zellen_anpassen()
'Aktualisierung des Bildschirms ausschalten
Application.ScreenUpdating = False
'zuerst Standard wieder herstellen
Rows("68:77").RowHeight = 12.75
Rows("82:91").RowHeight = 12.75
'Bereich 1
Range("AJ68:AT68").Select
Call AutoFitMergedCellRowHeight
Range("AJ69:AT69").Select
Call AutoFitMergedCellRowHeight
Range("AJ70:AT70").Select
Call AutoFitMergedCellRowHeight
Range("AJ71:AT71").Select
Call AutoFitMergedCellRowHeight
Range("AJ72:AT72").Select
Call AutoFitMergedCellRowHeight
Range("AJ73:AT73").Select
Call AutoFitMergedCellRowHeight
Range("AJ74:AT74").Select
Call AutoFitMergedCellRowHeight
Range("AJ75:AT75").Select
Call AutoFitMergedCellRowHeight
Range("AJ76:AT76").Select
Call AutoFitMergedCellRowHeight
Range("AJ77:AT77").Select
Call AutoFitMergedCellRowHeight
'Bereich 2
Range("AX68:BI68").Select
Call AutoFitMergedCellRowHeight
Range("AX69:BI69").Select
Call AutoFitMergedCellRowHeight
Range("AX70:BI70").Select
Call AutoFitMergedCellRowHeight
Range("AX71:BI71").Select
Call AutoFitMergedCellRowHeight
Range("AX72:BI72").Select
Call AutoFitMergedCellRowHeight
Range("AX73:BI73").Select
Call AutoFitMergedCellRowHeight
Range("AX74:BI74").Select
Call AutoFitMergedCellRowHeight
Range("AX75:BI75").Select
Call AutoFitMergedCellRowHeight
Range("AX76:BI76").Select
Call AutoFitMergedCellRowHeight
Range("AX77:BI77").Select
Call AutoFitMergedCellRowHeight
'Bereich 3
Range("AL82:AZ82").Select
Call AutoFitMergedCellRowHeight
Range("AL83:AZ83").Select
Call AutoFitMergedCellRowHeight
Range("AL84:AZ84").Select
Call AutoFitMergedCellRowHeight
Range("AL85:AZ85").Select
Call AutoFitMergedCellRowHeight
Range("AL86:AZ86").Select
Call AutoFitMergedCellRowHeight
Range("AL87:AZ87").Select
Call AutoFitMergedCellRowHeight
Range("AL88:AZ88").Select
Call AutoFitMergedCellRowHeight
Range("AL89:AZ89").Select
Call AutoFitMergedCellRowHeight
Range("AL90:AZ90").Select
Call AutoFitMergedCellRowHeight
Range("AL91:AZ91").Select
Call AutoFitMergedCellRowHeight
Application.ScreenUpdating = True
End Sub
'Zeilenumbruch von gebundenen Zellen
Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Dim iX As Integer
If ActiveCell.MergeCells Then
With ActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + _
MergedCellRgWidth
iX = iX + 1
Next
MergedCellRgWidth = MergedCellRgWidth + (iX - 1) * 0.71
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
End If
End Sub

12
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Laufzeit >5Minuten für kleines VBA Script
18.08.2012 12:53:04
{Boris}
Hi,
auf die Schnelle: Schalte nicht bloß die Bildschirmaktualisierung aus sondern vorallem die Berechung:
Application.Calculation = xlCalculationManual
'Dein Code
Application.Calculation = xlCalculationAutomatic
Zudem kann man immer auf Select verzichten. Außerdem können verbunden Zellen ne Menge Ärger bereiten (insider ;-) )
VG, Boris
evtl. noch jemand einen Tipp?
18.08.2012 15:26:58
Andy
Hallo Boris,
danke für den Tipp, habe ihn direkt eingebunden.
Vom Gefühl her würde ich sagen, es ist etwas schneller geworden, jedoch liegt die Laufzeit immer noch bei etwa 5 Minuten.
Hat vielleicht noch jemand anders einen Tipp?
Anzeige
AW: evtl. noch jemand einen Tipp?
18.08.2012 15:35:44
Hajo_Zi
Hallo Andy,
bei mir läuft das Teil in 1 Sekunde durch. Vielleicht liegt es an Deiner Datei?

AW: evtl. noch jemand einen Tipp?
18.08.2012 15:42:50
Josef

Hallo Andy,
sollte einen Tick schneller sein.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Zeilenhöhe_gebundene_Zellen_anpassen()
  Dim rngArea As Range, rngRow As Range
  Dim lngCalc As Long
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
  End With
  
  Rows("68:77").RowHeight = 12.75
  Rows("82:91").RowHeight = 12.75
  
  For Each rngArea In Range("AJ68:AT77,AX68:BI77,AL82:AZ91").Areas
    For Each rngRow In rngArea.Rows
      rngRow.Merge
      AutoFitMergedCellRowHeight rngRow
    Next
  Next
  
  ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "'Zeilenhöhe_gebundene_Zellen_anpassen'" & vbLf & String(60, "_") & _
        vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
        "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
        .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
        "VBA - Fehler in Modul - Modul1"
      .Clear
    End If
  End With
  
  On Error GoTo 0
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
    .DisplayAlerts = True
  End With
  
End Sub


'Zeilenumbruch von gebundenen Zellen
Sub AutoFitMergedCellRowHeight(Target As Range)
  Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
  Dim CurrCell As Range
  Dim ActiveCellWidth As Single, PossNewRowHeight As Single
  Dim iX As Integer
  
  With Target
    If .MergeCells Then
      With .Cells(1, 1).MergeArea
        If .Rows.Count = 1 And .WrapText = True Then
          CurrentRowHeight = .RowHeight
          ActiveCellWidth = .ColumnWidth
          For Each CurrCell In Selection
            MergedCellRgWidth = CurrCell.ColumnWidth + _
              MergedCellRgWidth
            iX = iX + 1
          Next
          MergedCellRgWidth = MergedCellRgWidth + (iX - 1) * 0.71
          .MergeCells = False
          .Cells(1).ColumnWidth = MergedCellRgWidth
          .EntireRow.AutoFit
          PossNewRowHeight = .RowHeight
          .Cells(1).ColumnWidth = ActiveCellWidth
          .MergeCells = True
          .RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
            CurrentRowHeight, PossNewRowHeight)
        End If
      End With
    End If
  End With
End Sub



« Gruß Sepp »

Anzeige
kleine Änderung
18.08.2012 16:24:29
Erich
Hi Sepp,
in AutoFitMergedCellRowHeight() läuft eine Schleife über Selection. Das hast du sicher nicht gewollt.
Besser wäre wohl

For Each CurrCell In .Cells           ' nicht: Selection
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich und: Schönes Wochenende allerseits!
jepp stimmt - Danke! o.T.
18.08.2012 16:59:19
Josef
« Gruß Sepp »

Rückmeldung zu Rainer und Josef Script
18.08.2012 16:02:11
Andy
Hallo,
ich habe eure Tipps soeben getest.
das Script von Rainer läuft etwas schneller, jedoch sind danach die betroffenen Reihen ausgeblendet, warum auch immer, im Code steht davon doch nichts...
beim Script von Josef kommt eine Fehlermeldung:
Fehlermeldung: 94
Unzulässige Verwendung von Null
ich bereite mal eben eine Datei mit dem entsprechenden Blatt dazu vor.
Anzeige
AW: evtl. noch jemand einen Tipp?
18.08.2012 16:20:52
Andy
so,
hier ist die Datei:

Die Datei https://www.herber.de/bbs/user/81474.xlsm wurde aus Datenschutzgründen gelöscht


die Testdatei läuft wesentlich schneller als mein Original :-(
zur Datei und Verwendung noch kurz etwas:
die Daten kommen durch eine Webabfrage in die Tabelle, danach werden sie im unteren rechten Bereich "auf Format" gebracht und anschließend in einer verknüpften Grafik oben link angezeit, dieser Bereich wird dann für eine Vereinszeitschrift ausgedruckt.
Ich hatte schon einzelnen Blöcke getrennt aufgebaut, so dass ich keine verbundenen Zellen hatte, jedoch wird mir damit regelmäßig das Layout zerschossen. Daher habe mich für diese Lösung entschlossen.
Anzeige
AW: Laufzeit >5Minuten für kleines VBA Script
18.08.2012 15:31:16
Ramses
Hallo
Unter der Voraussetzung dass ALLE deine gewählten Bereiche verbundene Zellen sind, die Schriftgrösse etwa 10/11 beträgt und Zeilenschaltungen in der Zelle vorhanden sind, sollte das deutlich schneller funktionieren
Sub Zeilenhöhe_gebundene_Zellen_anpassen()
On Error GoTo errExit
'Aktualisierung des Bildschirms ausschalten
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
'zuerst Standard wieder herstellen
Rows("68:77").RowHeight = 12.75
Rows("82:91").RowHeight = 12.75
Call AutoFitMergedCellRowHeight(Range("AJ68:AT77"))
Call AutoFitMergedCellRowHeight(Range("AX68:BI77"))
Call AutoFitMergedCellRowHeight(Range("AL81:AZ91"))
errExit:
With Application
.ScreenUpdating = True
.Calculation = xlAutomatic
End With
If Err.Number  0 Then
MsgBox Err.Description, vbOKOnly, "Fehlernummer: " & Err.Number
End If
End Sub
'Zeilenumbruch von gebundenen Zellen
Sub AutoFitMergedCellRowHeight(chkRange As Range)
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Dim i As Integer, x As Integer
For Each curcell In chkRange
If curcell.MergeCells Then
With curcell.MergeArea
If .WrapText = True Then
'Suche nach Zeilenschaltungen im Text
For i = 1 To Len(curcell.Text)
Select Case Mid(curcell.Text, i, 1)
Case Chr$(10), Chr$(13)
x = x + 1
End Select
Next i
'Mulitplizieren der Zeilenhöhe mit der Anzahl Zeilenschaltungen
curcell.RowHeight = curcell.RowHeight * x
End If
End With
x = 0
End If
Next
End Sub

Gruss Rainer
Anzeige
Testdatei
18.08.2012 16:22:30
Andy
so,
hier ist die Datei:

Die Datei https://www.herber.de/bbs/user/81474.xlsm wurde aus Datenschutzgründen gelöscht


die Testdatei läuft wesentlich schneller als mein Original :-(
zur Datei und Verwendung noch kurz etwas:
die Daten kommen durch eine Webabfrage in die Tabelle, danach werden sie im unteren rechten Bereich "auf Format" gebracht und anschließend in einer verknüpften Grafik oben link angezeit, dieser Bereich wird dann für eine Vereinszeitschrift ausgedruckt.
Ich hatte schon einzelnen Blöcke getrennt aufgebaut, so dass ich keine verbundenen Zellen hatte, jedoch wird mir damit regelmäßig das Layout zerschossen. Daher habe mich für diese Lösung entschlossen.
Anzeige
Danke!
21.08.2012 00:40:43
Andy
Hallo Sepp,
danke, Dein Script läuft.
Gruß Andy

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige