Live-Forum - Die aktuellen Beiträge
Datum
Titel
19.04.2024 09:26:26
Median für Zeilen mit gleichen Zeitstempel
19.04.2024 08:41:23
Zwei Makros in ein Arbeitsblatt - zweite wird nicht ausführt
18.04.2024 21:09:11
4 Spalten aus smarter Tabelle in andere smarte Tab. kopieren
18.04.2024 20:45:35
Worksheet_Activate für alle Sheets
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
844to848
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
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
844to848
844to848
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Makro optimieren / Zellen Farbe

Makro optimieren / Zellen Farbe
Roland
Hallo VBA-Profis
Mit untenstehendem Makro Fülle ich Zellen mit Farbe und Buchstaben, in Abhänigkeit von einem Code (ein "X") in verschiedenen Zeilen und der Ortschaft die in einer Spalte steht, in mehrere Tabellenblätter ab. Dabei darf keine Zelle überschrieben werden, die den Farbindex = 20 hat.
Das Makro funktioniert eigentlich. Nur braucht der Rechner mit voller CPU-Auslastung relativ lange bis das Makro durchgelaufen ist.
Was kann ich ändern damit das Makro schneller läuft, oder braucht diese Funktion einfach seine Zeit?
Für eure Antwort danke ich bestens.
Roland

Sub Zellenfärben()
Dim Zelle As Range
Dim i As Integer
Dim Bereich As Range
Application.ScreenUpdating = False
For i = 1 To Worksheets.Count - 5
Worksheets(i).Activate
ActiveSheet.Unprotect myPwd
Set Bereich = Range("F6:BO" & Cells(Rows.Count, 4).End(xlUp).Row)
Bereich.Select
With Selection
For Each Zelle In Selection
If Not .Interior.ColorIndex = 20 Then
If Cells(207, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Aarau" Then
Zelle.Interior.ColorIndex = 40
Zelle.Value = "R"
End If
End If
If Not .Interior.ColorIndex = 20 Then
If Cells(208, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Bellinzona" Then
Zelle.Interior.ColorIndex = 40
Zelle.Value = "R"
End If
End If
If Not .Interior.ColorIndex = 20 Then
If Cells(209, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Bern" Then
Zelle.Interior.ColorIndex = 40
Zelle.Value = "R"
End If
End If
If Not .Interior.ColorIndex = 20 Then
If Cells(216, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Conthey" Then
Zelle.Interior.ColorIndex = 40
Zelle.Value = "R"
End If
End If
If Not .Interior.ColorIndex = 20 Then
If Cells(209, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Fraubrunnen" Then
Zelle.Interior.ColorIndex = 40
Zelle.Value = "R"
End If
End If
If Not .Interior.ColorIndex = 20 Then
If Cells(216, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Glis" Then
Zelle.Interior.ColorIndex = 40
Zelle.Value = "R"
End If
End If
If Not .Interior.ColorIndex = 20 Then
If Cells(209, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Ins" Then
Zelle.Interior.ColorIndex = 40
Zelle.Value = "R"
End If
End If
If Not .Interior.ColorIndex = 20 Then
If Cells(209, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Ittigen" Then
Zelle.Interior.ColorIndex = 40
Zelle.Value = "R"
End If
End If
If Not .Interior.ColorIndex = 20 Then
If Cells(210, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Luzern" Then
Zelle.Interior.ColorIndex = 40
Zelle.Value = "R"
End If
End If
If Not .Interior.ColorIndex = 20 Then
If Cells(211, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Nyon" Then
Zelle.Interior.ColorIndex = 40
Zelle.Value = "R"
End If
End If
If Not .Interior.ColorIndex = 20 Then
If Cells(217, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Ohringen" Then
Zelle.Interior.ColorIndex = 40
Zelle.Value = "R"
End If
End If
If Not .Interior.ColorIndex = 20 Then
If Cells(212, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Sargans" Then
Zelle.Interior.ColorIndex = 40
Zelle.Value = "R"
End If
End If
If Not .Interior.ColorIndex = 20 Then
If Cells(213, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Sissach" Then
Zelle.Interior.ColorIndex = 40
Zelle.Value = "R"
End If
End If
If Not .Interior.ColorIndex = 20 Then
If Cells(214, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "St. Gallen" Then
Zelle.Interior.ColorIndex = 40
Zelle.Value = "R"
End If
End If
If Not .Interior.ColorIndex = 20 Then
If Cells(215, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "St-Imier" Then
Zelle.Interior.ColorIndex = 40
Zelle.Value = "R"
End If
End If
If Not .Interior.ColorIndex = 20 Then
If Cells(218, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Zürich" Then
Zelle.Interior.ColorIndex = 40
Zelle.Value = "R"
End If
End If
Next
End With
Range("A5").Select
ActiveSheet.Protect myPwd
Next i
Application.ScreenUpdating = True
End Sub

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Makro optimieren / Zellen Farbe
06.02.2007 22:34:28
Horst
Hi,
alle selects raus, Events aus, Berechnung manuell.
Das konzept scheint zweifelhaft.
mfg Horst
AW: Makro optimieren / Zellen Farbe
06.02.2007 22:51:41
Roland
Hallo Horst
Danke für Deine Antwort. Leider blicke ich nicht ganz durch, was Du meinst. Da reicht meine VBA-Wissen nicht aus.
Vielleicht kannst Du mir das anhand von einem Beispiel erklären.
Besten Dank
mfg Roland
AW: Makro optimieren / Zellen Farbe
06.02.2007 22:59:24
Ramses
Hallo
Ich weiss nicht wieviele Tabellen du in deiner Mappe hast, aber du hast mit deinen If-Abfragen alleine pro Tabelle bereits mehr 240'000 !!! Prüfungen.
Hier mal eine "etwas" optimierte Variante bei der die Farbabfrage mal auf 1 reduziert wurde.
Im zweiten Code habe ich das ganze mal auf "Select Case" umgestellt.
Keine Ahnung ob das was bringt, aber "Select Case" Anweisungen werden im allgemeinen schneller abgearbeitet als "If"-Anweisungen
Probier einfach mal beide Varianten aus:
Option Explicit

Sub Zellenfärben_opt1()
    Dim Zelle As Range
    Dim i As Integer, n As Integer
    Dim starttime As Double
    Dim Bereich As Range
    Application.ScreenUpdating = False
    Application.Calculate = xlManual
    Application.EnableEvents = False
    starttime = Now
    For i = 1 To Worksheets.Count - 5
        Worksheets(i).Activate
        ActiveSheet.Unprotect myPwd
        Set Bereich = Range("F6:BO" & Cells(Rows.Count, 4).End(xlUp).Row)
        For Each Zelle In Bereeich
            If Not .Interior.ColorIndex = 20 Then
                If Cells(207, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Aarau" Then
                    Zelle.Interior.ColorIndex = 40
                    Zelle.Value = "R"
                End If
                If Cells(208, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Bellinzona" Then
                    Zelle.Interior.ColorIndex = 40
                    Zelle.Value = "R"
                End If
                If Cells(209, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Bern" Then
                    Zelle.Interior.ColorIndex = 40
                    Zelle.Value = "R"
                End If
                If Cells(216, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Conthey" Then
                    Zelle.Interior.ColorIndex = 40
                    Zelle.Value = "R"
                End If
                If Cells(209, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Fraubrunnen" Then
                    Zelle.Interior.ColorIndex = 40
                    Zelle.Value = "R"
                End If
                If Cells(216, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Glis" Then
                    Zelle.Interior.ColorIndex = 40
                    Zelle.Value = "R"
                End If
                If Cells(209, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Ins" Then
                    Zelle.Interior.ColorIndex = 40
                    Zelle.Value = "R"
                End If
                If Cells(209, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Ittigen" Then
                    Zelle.Interior.ColorIndex = 40
                    Zelle.Value = "R"
                End If
                If Cells(210, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Luzern" Then
                    Zelle.Interior.ColorIndex = 40
                    Zelle.Value = "R"
                End If
                If Cells(211, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Nyon" Then
                    Zelle.Interior.ColorIndex = 40
                    Zelle.Value = "R"
                End If
                If Cells(217, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Ohringen" Then
                    Zelle.Interior.ColorIndex = 40
                    Zelle.Value = "R"
                End If
                If Cells(212, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Sargans" Then
                    Zelle.Interior.ColorIndex = 40
                    Zelle.Value = "R"
                End If
                If Cells(213, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Sissach" Then
                    Zelle.Interior.ColorIndex = 40
                    Zelle.Value = "R"
                End If
                If Cells(214, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "St. Gallen" Then
                    Zelle.Interior.ColorIndex = 40
                    Zelle.Value = "R"
                End If
                If Cells(215, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "St-Imier" Then
                    Zelle.Interior.ColorIndex = 40
                    Zelle.Value = "R"
                End If
                If Cells(218, Zelle.Column) = "X" And Cells(Zelle.Row, 4) = "Zürich" Then
                    Zelle.Interior.ColorIndex = 40
                    Zelle.Value = "R"
                End If
            End If
        Next
        Range("A5").Select
        ActiveSheet.Protect myPwd
    Next i
    Application.Calculate = xlAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    MsgBox "Dauer: " & Format(Now - starttime, "hh:mm:ss"), vbInformation + vbOKOnly, "Fertig"
End Sub


Sub Zellenfärben_opt2()
    Dim Zelle As Range
    Dim i As Integer, n As Integer
    Dim Bereich As Range
    Dim starttime As Double
    Application.ScreenUpdating = False
    Application.Calculate = xlManual
    Application.EnableEvents = False
    starttime = Now
    For i = 1 To Worksheets.Count - 5
        Worksheets(i).Activate
        ActiveSheet.Unprotect myPwd
        Set Bereich = Range("F6:BO" & Cells(Rows.Count, 4).End(xlUp).Row)
        For Each Zelle In Bereeich
            If Not .Interior.ColorIndex = 20 Then
                Select Case UCase(Cells(207, Zelle.Column))
                    Case "X"
                        Select Case Cells(Zelle.Row, 4)
                            Case "Aarau"
                                Zelle.Interior.ColorIndex = 40
                                Zelle.Value = "R"
                        End Select
                End Select
                Select Case UCase(Cells(208, Zelle.Column))
                    Case "X"
                        Select Case Cells(Zelle.Row, 4)
                            Case "Bellinzona"
                                Zelle.Interior.ColorIndex = 40
                                Zelle.Value = "R"
                        End Select
                End Select
                Select Case UCase(Cells(209, Zelle.Column))
                    Case "X"
                        Select Case Cells(Zelle.Row, 4)
                            Case "Bern", "Fraubrunnen", "Ins", "Ittigen"
                                Zelle.Interior.ColorIndex = 40
                                Zelle.Value = "R"
                        End Select
                End Select
                Select Case UCase(Cells(210, Zelle.Column))
                    Case "X"
                        Select Case Cells(Zelle.Row, 4)
                            Case "Luzern"
                                Zelle.Interior.ColorIndex = 40
                                Zelle.Value = "R"
                        End Select
                End Select
                Select Case ucse(Cells(211, Zelle.Column))
                    Case "X"
                        Select Case Cells(Zelle.Row, 4)
                            Case "Nyon"
                                Zelle.Interior.ColorIndex = 40
                                Zelle.Value = "R"
                        End Select
                End Select
                Select Case UCase(Cells(212, Zelle.Column))
                    Case "X"
                        Select Case Cells(Zelle.Row, 4)
                            Case "Sargans"
                                Zelle.Interior.ColorIndex = 40
                                Zelle.Value = "R"
                        End Select
                End Select
                Select Case UCase(Cells(213, Zelle.Column))
                    Case "X"
                        Select Case Cells(Zelle.Row, 4)
                            Case "Sissach"
                                Zelle.Interior.ColorIndex = 40
                                Zelle.Value = "R"
                        End Select
                End Select
                Select Case UCase(Cells(214, Zelle.Column))
                    Case "X"
                        Select Case Cells(Zelle.Row, 4)
                            Case "St. Gallen"
                                Zelle.Interior.ColorIndex = 40
                                Zelle.Value = "R"
                        End Select
                End Select
                Select Case UCase(Cells(215, Zelle.Column))
                    Case "X"
                        Select Case Cells(Zelle.Row, 4)
                            Case "St-Imier"
                                Zelle.Interior.ColorIndex = 40
                                Zelle.Value = "R"
                        End Select
                End Select
                Select Case UCase(Cells(216, Zelle.Column))
                    Case "X"
                        Select Case Cells(Zelle.Row, 4)
                            Case "Conthey", "Glis"
                                Zelle.Interior.ColorIndex = 40
                                Zelle.Value = "R"
                        End Select
                End Select
                Select Case UCase(Cells(217, Zelle.Column))
                    Case "X"
                        Select Case Cells(Zelle.Row, 4)
                            Case "Ohringen"
                                Zelle.Interior.ColorIndex = 40
                                Zelle.Value = "R"
                        End Select
                End Select
                Select Case uscase(Cells(218, Zelle.Column))
                    Case "X"
                        Select Case Cells(Zelle.Row, 4)
                            Case "Zürich"
                                Zelle.Interior.ColorIndex = 40
                                Zelle.Value = "R"
                        End Select
                End Select
            End If
        Next
        Range("A5").Select
        ActiveSheet.Protect myPwd
    Next i
    Application.Calculate = xlAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    MsgBox "Dauer: " & Format(Now - starttime, "hh:mm:ss"), vbInformation + vbOKOnly, "Fertig"
End Sub


Gruss Rainer
Anzeige
Noch was...
06.02.2007 23:03:24
Ramses
Hallo
beachte mal die Abfrage der Zelle 209 und 216!
Ich habe nur deinen Code genommen und in der zweiten Variante mal zusammengestellt.
Während du sonst immer nur einen Ort pro Zelle abfragst, fragst du hier 4 bzw. 2 Orte ab.
Mal prüfen ob das stimmt
Gruss Rainer
Habe in der Zwischenzeit auch an einer...
06.02.2007 23:52:57
Luc:-?
...Lösung gebastelt, Roland,
(konnte ja nicht ahnen, dass du dich deines Landsmannes annimmst, Rainer... ;-) ) und bin zu folgender Lösung gekommen (kannst du ja durch Ramses' Besonderheiten ergänzen):
1. Im (Klassen-)Modul der Tabelle... 

Option Explicit
Const myPwd As String = "xyz"
Private Sub Worksheet_Activate()
ActiveSheet.Protect password:=myPwd, userinterfaceonly:=True
End Sub

...damit das .Unprotect-.Protect-Paar entfallen kann.
2. In deinem Standardmodul die wie folgt korrigierte Prozedur... 

Option Explicit
Sub Zellenfärben()
Dim i As Integer, Bereich As Range, Zelle As Range
Application.ScreenUpdating = False
For i = 1 To Worksheets.Count - 5
With Worksheets(i)
Set Bereich = Intersect(.UsedRange, .Range(.Cells(6, 6), _
.Cells(.Cells(.Rows.Count, 4).End(xlUp).Row, 67)))
For Each Zelle In Bereich
If Not Zelle.Interior.ColorIndex = 20 Then
Select Case .Cells(Zelle.Row, 4).Value
Case "Aarau"
If .Cells(207, Zelle.Column).Value = "X" Then
Zelle.Interior.ColorIndex = 40
Zelle.Value = "R"
End If
Case "Bellinzona"
If .Cells(208, Zelle.Column).Value = "X" Then
Zelle.Interior.ColorIndex = 40
Zelle.Value = "R"
End If
'                   ...usw bis...
Case "Zürich"
If .Cells(218, Zelle.Column).Value = "X" Then
Zelle.Interior.ColorIndex = 40
Zelle.Value = "R"
End If
End Select
End If
Next Zelle
Range("A5").Select
End With
Next i
Set Bereich = Nothing: Set Zelle = Nothing
Application.ScreenUpdating = True
End Sub

Gruß Luc :-?
Anzeige
AW: Makro optimieren / Zellen Farbe
06.02.2007 23:18:39
Daniel
hallo
insgesamt grosser murks.
1. du verwendest jedesmal die gleiche if-abfrage, da könntest du doch gleich alles in einen If-Block schreiben
2. glaube ich kaum daß dein Makro richtig funktioniert
du baust eine FOR-EACH-Schleife mit ZELLE als Schleifenelement, beziehts dich dann aber in der IF-Abfrage auf das Range-OBJEKT BEREICH, daß du in der WITH-Klammer festgelegt hast.
Damit begehst du 2 Fehler:
- das Abfrage-Objekt ändert sich innerhalb der Schleife nicht, damit das Abfrageergebnis immer das gleiche. Somit kann die Schleife innerhalb der IF-Abfrage stehen, weil das IF-Abfrage ja für ganze Schleife gleich ist.
- Fragst du die Color-Eigenschaft eines Zellbereiches ab. Da bekommst du nur ein sinnvolles Ergebnis, wenn ALLE Zellen des Bereiches die GLEICHE Farbe haben, ansonsten ist das Ergebnis NULL
Insgesamt macht also deine ganze Abfrage keinen Sinn. Wahrscheinlich sollte sich die Abfrage auf ZELLE beziehen.
Außderdem macht es keinen Sinn, einen Zellbereich einer Objekt-Variable zuzuweisen (BEREICH), um es dann zu selekiteren.
Wenn ich so eine Objekt-Variable habe, spreche ich sie immer direkt an oder verwende sie in der With-Klammer, aber erst zu selektieren ist überflüssig.
also das ganze noch mal genau überdenken und durchstrukturieren.
gruß, Daniel
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige