Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
968to972
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
968to972
968to972
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Sub beschleunigen

Sub beschleunigen
11.04.2008 19:49:00
Mathias
Hallo,
folgende Sub benötigt bei mir ca. 4-5 Sekunden, um Zellen mit einen bestimmten Inhalt entsprechend zu formatieren.
Ich würde den Code gern beschleunigen, indem ich Tabelle1.Range("E2:BB463") zunächst in ein Array oder Datenfeld kopiere, dort bearbeite und dann in einem Rutsch wieder in den ursprünglichen Zellbereich zurück schreibe.
In dem Array müßte der Zellinhalt, die Textfarbe und die Hintergrundfarbe bearbeitet werden.
Ich hab schon alles Mögliche probiert, komme aber irgendwie nicht weiter. Hat jemand einen Tipp für mich?

Sub Updaten()
Dim i As Integer
Dim Zelle As Range, Bereich As Range
On Error GoTo Ende
Set Bereich = Tabelle1.Range("E2:BB463")
For Each Zelle In Bereich
If Zelle.Value > "" Then
With Zelle  ' Zelle mit OptionenArr(i).Option vergleichen
i = 1
Do While (.Value  OptionenArr(i).Option) And (i 


-------------------------------------------
OptionenArr ist wie folgt definiert:
Type OptionenType
Option As String
Textfarbe As Integer
Hintergrundfarbe As Integer
End Type
Public OptionenArr(1 To 20) As OptionenType
Viele Grüße
Mathias

16
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Sub beschleunigen
11.04.2008 19:55:01
Uduuh
Hallo,
in einem Arry kannst du nur Werte und Formeln bearbeiten
Gruß aus’m Pott
Udo

AW: Sub beschleunigen
11.04.2008 20:18:37
Nepumuk
Hallo Mathias,
es wäre schon mal wesentlich schneller, wenn du die Zellwert in ein Array schreibst und dort die Vergleiche durchführst. Oder du suchst gezielt nach den Werten. Denn bei deiner Konstruktion werden für jede nicht zutreffende Zelle 21 Abfragen getätigt. Für jede zutreffende mindestens zwei. Das ist gelinde gesagt ziemlich unökonomisch.
Gruß
Nepumuk

AW: Sub beschleunigen
11.04.2008 21:40:00
Mathias
Hallo,
danke für die Tipps.
Schade, ich hatte gehofft es gibt sowas wie ein array[1..x] of range oder so ähnlich, wo man alle Zellen zwischenspeichern und alle Eigenschaften bearbeiten kann.
Dann muss ich ja wenigstens nicht mehr weitersuchen und konzentriere mich jetzt darauf, die Zellwerte in ein array zu bekommen und die Vergleiche zu minimieren.
Kann man evtl. alle Zellen mit Inhalt irgendwie direkt ansprechen, ohne vorher den Zellinhalt auslesen zu müssen, z.B. sowas wie "For Each UsedCell in Bereich" oder so ähnlich?
Viele Grüße
Mathias

Anzeige
AW: Sub beschleunigen
11.04.2008 21:44:00
Uduuh
Hallo,

Kann man evtl. alle Zellen mit Inhalt irgendwie direkt ansprechen, ohne vorher den Zellinhalt auslesen zu müssen, z.B. sowas wie "For Each UsedCell in Bereich" oder so ähnlich?


Schau dir mal die SpecialCells-Methode an
Gruß aus’m Pott
Udo

AW: Sub beschleunigen
11.04.2008 22:00:00
Mathias
Hallo Udo,
danke werd´ ich machen.
Wenn ich die Sub erfolgreich überarbeitet hab´, stelle ich sie hier nochmal rein.
Viele Grüße
Mathias

AW: Sub beschleunigen
11.04.2008 23:32:00
Nepumuk
Hallo Mathias,
nachdem jetzt schon jede Menge Vorschläge eingegangen sind, mal einer von mir:
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Type OptionenType
    strOption As String
    intTextfarbe As Integer
    intHintergrundfarbe As Integer
End Type

Private OptionenArr(1 To 20) As OptionenType
Private sngTimer As Single

Public Sub start()
    Dim intIndex As Integer
    For intIndex = 1 To 20
        With OptionenArr(intIndex)
            .strOption = CStr(intIndex)
            .intTextfarbe = intIndex
            .intHintergrundfarbe = 1 + intIndex
        End With
    Next
    Call test
End Sub

Public Sub test()
    
    Dim intIndex As Integer
    Dim objCell As Range, objRange As Range
    Dim strAdress As String
    
    sngTimer = Timer
    
    Application.ScreenUpdating = False
    With Tabelle1.Range("E2:BB463")
        .Interior.ColorIndex = xlNone
        .Font.ColorIndex = xlAutomatic
        For intIndex = 1 To 20
            Set objCell = .Find(What:=OptionenArr(intIndex).strOption, _
                LookIn:=xlValues, LookAt:=xlWhole)
            If Not objCell Is Nothing Then
                strAdress = objCell.Address
                Set objRange = objCell
                Do
                    Set objRange = Union(objCell, objRange)
                    Set objCell = .FindNext(objCell)
                Loop While Not objCell Is Nothing And objCell.Address <> strAdress
                objRange.Interior.ColorIndex = OptionenArr(intIndex).intHintergrundfarbe
                objRange.Font.ColorIndex = OptionenArr(intIndex).intTextfarbe
                Set objRange = Nothing
            End If
        Next
    End With
    Application.ScreenUpdating = True
    
    Debug.Print Timer - sngTimer
    
End Sub

Gruß
Nepumuk

Anzeige
AW: Sub beschleunigen
12.04.2008 00:05:13
Uduuh
Hallo Max,
schon ganz gut. ;-)
Aber das hier ist doppelt so schnell:

Option Explicit
Type OptionenType
Option As String
Textfarbe As Integer
Hintergrundfarbe As Integer
Range As Range
End Type
Public OptionenArr(1 To 20) As OptionenType
Sub DoIt()
Dim i As Integer, t As Double
t = Timer
For i = 1 To 20
OptionenArr(i).Option = Chr(96 + i)
OptionenArr(i).Hintergrundfarbe = i
OptionenArr(i).Textfarbe = i + 15
Set OptionenArr(i).Range = Nothing
Next i
Updaten
MsgBox Timer - t
End Sub
Sub Updaten()
'© Uduuh 2008/04/10; www.excelerator.de
Dim i As Integer
Dim Bereich As Range
Dim vntArray, j As Long, k As Long
Application.ScreenUpdating = False
Set Bereich = Tabelle2.Range("E2:BB463")
vntArray = Bereich
For j = 1 To 462
For k = 1 To 50
For i = 1 To 20
If vntArray(j, k) = OptionenArr(i).Option Then
If OptionenArr(i).Range Is Nothing Then
Set OptionenArr(i).Range = Bereich(j, k)
Else
Set OptionenArr(i).Range = Union(OptionenArr(i).Range, Bereich(j, k))
End If
Exit For
End If
Next i
Next k
Next j
Bereich.Interior.ColorIndex = xlNone
Bereich.Font.ColorIndex = xlAutomatic
For i = 1 To 20
If Not OptionenArr(i).Range Is Nothing Then
OptionenArr(i).Range.Interior.ColorIndex = OptionenArr(i).Hintergrundfarbe
OptionenArr(i).Range.Font.ColorIndex = OptionenArr(i).Textfarbe
End If
Next i
Set Bereich = Nothing
Application.ScreenUpdating = True
End Sub


Gruß aus’m Pott
Udo

Anzeige
AW: Sub beschleunigen
12.04.2008 00:22:32
Nepumuk
Hallo Udo,
ist klar, dass in dem Fall ein Array schneller ist als die Find - Methode. Die liegt erst bei mehr als 100.000 Zellen in der Geschwindigkeit vorne. Darunter sind Arrays schneller. Da aber Mathias nur VBA - gut kann, wollte ich ihn nicht damit überfordern. ;-)
Gruß
Nepumuk

DANK AN ALLE
12.04.2008 07:17:30
Mathias
Hallo,
vielen vielen Dank für alle eure Vorschläge!!!
Ich hab jetzt garnicht mehr gedacht, dass noch so tolle Beispiele kommen.
Hab jetzt erstmal den Code von Udo eingebaut (rasend schnell, Danke Udo!)
Auf die anderen Beiträge werde ich sicher auch nochmal zurückgreifen,
da auch dort viele gute Anregungen enthalten sind.
Nochmals vielen Dank euch allen und ein schönes WE! :-)
Viele Grüße
Mathias

Anzeige
AW: Sub beschleunigen
11.04.2008 20:30:00
Reinhard
Hi Matthias,
ungetestet, vielleicht bringts ja paar Millisekunden falls es kappt.
Was mir noch als ebenfalls ungetesteten Tipp einfällt, wie kam denn die Farbe aufs Blatt, manuell oder bed. Formatierung? Im ersten Fall könntest du dir Hilfssplaten basteln die die Farbwerte der zellen des Bereichs enthalten, diese Hilfszellen kannst du ja dann auch in einem Rutsch einlesen.
Um den Farbwert zu erhalten mußt du einmalig einen Namen wie z.B. Farbe vergeben der sich auf die Formel:
=Zelle.Zuordnen(x;E2)
bezieht, wichtig ist daß du bei der Namensvergabe in der Zelle stehst, die später den Farbwert von E2 zeigen soll, nehmen wir man an BC2, denn dann kannst du die Formel die du dann in BC2 einträgst:
=Farbe
nach rechts und unten kopieren.
Das "x" ist eine Zahl, die ich grad nicht auswndig weiß, google mal im Web oder hier im Archiv nach:
Excel Farbe Zelle.Zuordnen
wirst sicher leicht fündig.
Den eingelesen Hauptbereich dann anzumalen, da mußt du wohl m.E. Zelle für Zelle durchgehen *denk*
Hier der nur winzig veränderte Code:

Option Explicit
Sub Updaten()
Dim i As Byte, Zelle As Range, Bereich As Range
On Error GoTo Ende
Set Bereich = Tabelle1.Range("E2:BB463")
With Bereich
.Interior.ColorIndex = xlNone             ' Hintergrundfarbe keine
.Font.ColorIndex = 1                          '  Textfarbe schwarz
For Each Zelle In .Cells
If Zelle.Value > "" Then
With Zelle  ' Zelle mit OptionenArr(i).Option vergleichen
i = 1
Do While (.Value  OptionenArr(i).Option) And (i 

Gruß
Reinhard

Anzeige
AW: Sub beschleunigen
11.04.2008 21:43:49
Mathias
Hallo,
danke für den Tipp. Werd ich mir die Tage mal genauer anschauen und mich dann nochmal melden, wenns klappt.
Ich denke, ich brauche allerdings etwas mehr Optimierung, als ein paar Millisekunden, da das Ganze im Moment echt lahm ist...
Viele Grüße
Mathias

AW: Sub beschleunigen: Idee
11.04.2008 21:40:47
Uduuh
Hallo,
nur mal als Idee:
Du konntest dir mit Union 20 Ranges als Array (arrRanges(1 to 20)) zusammenbasteln und diese in einer Schleife jeweils auf einen Schlag formatieren.
Obs was bringt, musst du aber selbst testen.
Gruß aus’m Pott
Udo

Anzeige
AW: Sub beschleunigen: Idee
11.04.2008 21:47:46
Mathias
Hallo Udo,
danke für den Super-Tipp! An sowas in der Art hab ich auch schon mal gedacht.
Werd ich sicher mal testen.
Ich hab allerdings noch keine echte Idee, wie man die Zahl der Vergleiche verringern könnte...
Viele Grüße
Mathias

Vorschlag
11.04.2008 22:34:56
Uduuh
Hallo,
ungetestet:

Sub Updaten()
Dim i As Integer
Dim Zelle As Range, Bereich As Range
Dim arrRanges(1 To 20) As Range
Dim blnFound As Boolean
On Error GoTo Ende
Set Bereich = Tabelle1.Range("E2:BB463")
For Each Zelle In Union(Bereich.SpecialCells(xlCellTypeConstants), _
Bereich.SpecialCells(xlCellTypeFormulas))
blnFound = False
For i = 1 To 20
If Zelle.Value = OptionenArr(i).Option Then
blnFound = True
Exit For
End If
Next i
If blnFound = True Then
If arrRanges(i) Is Nothing Then
Set arrRanges(i) = Zelle
Else
Set arrRanges(i) = Union(arrRanges(i), Zelle)
End If
End If
Next Zelle
Bereich.Interior.ColorIndex = xlNone
Bereich.Font.ColorIndex = xlAutomatic
For i = 1 To 20
If Not arrRanges(i) Is Nothing Then
arrRanges(i).Interior.ColorIndex = OptionenArr(i).Hintergrundfarbe
arrRanges(i).Font.ColorIndex = OptionenArr(i).Textfarbe
End If
Next i
Set Bereich = Nothing
Ende:
On Error GoTo 0
End Sub


Gruß aus’m Pott
Udo

Anzeige
AW: Sub beschleunigen
11.04.2008 22:39:00
Daniel
Hi
ich kanns leider nicht testen, aber ein paar sachen kommen mir überflüssig vor:
so solltest du zu beginn für alle Zellen die Farbe auf einen Schlag zurücksetzen und dann nur noch für die betroffenen die Farbe ändern.
das ist effektiver, als für jede Zelle einzeln die Farbe ändern.
Außerdem ist die letze IF-Abfrage überflüssig, da das ja schon in der Loop-Schleife davor abgefragt wird,,ist diese Abfrage doppelt und kann zusammengefasst werden.

Sub Updaten()
Dim i As Integer
Dim Zelle As Range, Bereich As Range
On Error GoTo Ende
Set Bereich = Tabelle1.Range("E2:BB463")
With Bereich                       ' alle Zellen
.Interior.ColorIndex = xlNone   ' Hintergrundfarbe keine
.Font.ColorIndex = 1            '  Textfarbe schwarz
End With
For Each Zelle In Bereich
With Zelle
If .Value > "" Then
' Zelle mit OptionenArr(i).Option vergleichen
For i = i To 20
If .Value = OptionenArr(i).Option Then
.Interior.ColorIndex = OptionenArr(i).Hintergrundfarbe  ' dann  _
Hintergrundfarbe
.Font.ColorIndex = OptionenArr(i).Textfarbe     ' und Textfarbe  _
setzen
Exit For
End If
Next
End If
End With
Next Zelle
Set Bereich = Nothing
Exit Sub
Ende:
On Error GoTo 0
End Sub


btw On Error Resume Next sollte man nie pauschal in einem Makro verwenden.
wenn ein Fehler auftritt, wird er auf diese weise vertuscht, und du bekommst u.U. falsche Ergebnisse, ohne es zu merken. Außderdem ist die Fehlersuche viel einfacher, wenn das Makro an der entscheidenden Stelle abbricht.
On Error Resume Next sollte nur geziehlt dann eingesetzt werden, wenn Funktionen auch bei regulärem Ablauf fehler verursachen. Aber auch dann wird nur genau diese Funkton in OnErrorResumeNext und OnErrorGoto0 gekapselt.
Gruß, Daniel

Anzeige
AW: Sub beschleunigen
11.04.2008 22:48:00
Uduuh
Hallo Daniel,

Außerdem ist die letze IF-Abfrage überflüssig, 


womit du völlig Recht hast. Manchmal ist man blind.


Sub Updaten()
Dim i As Integer
Dim Zelle As Range, Bereich As Range
Dim arrRanges(1 To 20) As Range
On Error GoTo Ende
Set Bereich = Tabelle1.Range("E2:BB463")
For Each Zelle In Union(Bereich.SpecialCells(xlCellTypeConstants), _
Bereich.SpecialCells(xlCellTypeFormulas))
blnFound = False
For i = 1 To 20
If Zelle.Value = OptionenArr(i).Option Then
If arrRanges(i) Is Nothing Then
Set arrRanges(i) = Zelle
Else
Set arrRanges(i) = Union(arrRanges(i), Zelle)
End If
Exit For
End If
Next i
Next Zelle
Bereich.Interior.ColorIndex = xlNone
Bereich.Font.ColorIndex = xlAutomatic
For i = 1 To 20
If Not arrRanges(i) Is Nothing Then
arrRanges(i).Interior.ColorIndex = OptionenArr(i).Hintergrundfarbe
arrRanges(i).Font.ColorIndex = OptionenArr(i).Textfarbe
End If
Next i
Set Bereich = Nothing
Ende:
On Error GoTo 0
End Sub


Gruß aus’m Pott
Udo

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige