Live-Forum - Die aktuellen Beiträge
Datum
Titel
26.04.2024 12:46:38
Nutzereingaben Speichern und Laden
26.04.2024 11:49:48
VAB und Bedingte Formatierung nimmt die Farbe im Makro nicht
26.04.2024 11:38:46
Acrobat PDF Formularfelder mit Excel ausfüllen
26.04.2024 11:23:04
zählen wenn - aber nur die selektierten Zeilen
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1736to1740
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
1736to1740
1736to1740
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

VBA läuft 35 sec.

VBA läuft 35 sec.
07.02.2020 14:07:09
Thomas
Also, ich probiere es noch einmal.
und ich hoffe, dass ich mich diesmal verständlich ausdrücke.
Ich hab mir jetzt hier ein Script gebastelt, welches sogar nach meinen Vorstellungen funktioniert.
Nur brauch es 35 sec. bis es durch ist.
Folgendes habe ich nun.
Private Sub Worksheet_Activate()
Dim cell
Worksheets("Overview").Unprotect Password:="_______"
For Each cell In Worksheets("Overview").Range("B7:ABA7").Cells
cell.Interior.Pattern = xlNone
cell.Font.Color = RGB(255, 255, 255) 'white
If cell >= Worksheets("Milestone").Range("K9") And cell = Worksheets("Milestone").Range("K10") And cell = Worksheets("Milestone").Range("K11") And cell = Worksheets("Milestone").Range("K12") And cell = Worksheets("Milestone").Range("K13") And cell = Worksheets("Milestone").Range("K14") And cell = Worksheets("Milestone").Range("K15") And cell = Worksheets("Milestone").Range("K16") And cell = Worksheets("Milestone").Range("K17") And cell = Worksheets("Milestone").Range("K18") And cell = Worksheets("Milestone").Range("K19") And cell = Worksheets("Milestone").Range("K20") And cell = Worksheets("Milestone").Range("K21") And cell = Worksheets("Milestone").Range("K22") And cell = Worksheets("Milestone").Range("K23") And cell = Worksheets("Milestone").Range("K24") And cell = Worksheets("Milestone").Range("K25") And cell

Das Script besteht aus 15 oben gezeigten Blöcken in der sich nur
For Each cell In Worksheets("Overview").Range("B7:ABA7").Cells
von B7:ABA7 bis B35:ABA35 (nur die ungeraden Zeilen)
und
If cell >= Worksheets("Milestone").Range("K9") And cell cell.Interior.Color = RGB(0, 191, 255) 'deep sky blue
cell.Font.Color = cell.Interior.Color
End If
die Spalten in Range("K ") und Range("L") sich bis DS btw. DT ( um jeweils 8 Spalten, Also von K zu S und von L zu T..... bis DS bzw. DT ändern.
Am Ende kommt ein Gantt-Diagramm raus, bei dem sich die Balken hintereinander anstatt, wie gewohnt, versetzt untereinander dargestellt werden.
Kann man das irgenwie verschlanken, damit´s flüssiger läuft ?
Ursprünglich wollte ich dies mit bedingten Formatierungen lösen, die Formel hierzu sieht folgendermaßen aus
=UND(B$5>=Milestone!$K$9;B$5 B5 weil sich in B5 der "Zeitstrahl" befindet. Der Schreibaufwand ist hier aber absurd hoch.
16 Regeln * 15 Zeilen = 240 Regeln ohne copy and paste.... (der Formeleditor ist hier wenig komfortabel)
dann wollte ich es über
If Zelle B5 >= K9 und Zelle B5 Also hab ich den Zeitstrahl in jetzt 16 Zeilen stehen, gefällt mir nicht... aber irgendwas is ja immer....

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

Betreff
Datum
Anwender
Anzeige
AW: VBA läuft 35 sec.
07.02.2020 15:27:23
Nepumuk
Hallo Thomas,
so schneller?
Private Sub Worksheet_Activate()
    
    Dim objCell As Range
    
    Application.ScreenUpdating = False
    
    Call Worksheets("Overview").Unprotect(Password:="_______")
    
    With Worksheets("Milestone")
        
        For Each objCell In Worksheets("Overview").Range("B7:ABA7")
            
            objCell.Interior.Pattern = xlPatternNone
            objCell.Font.Color = RGB(255, 255, 255) 'white
            
            If objCell.Value >= .Range("K9").Value And objCell.Value <= .Range("L9").Value Then
                
                objCell.Interior.Color = RGB(0, 191, 255) 'deep sky blue
                objCell.Font.Color = RGB(0, 191, 255)
                
            ElseIf objCell.Value >= .Range("K10").Value And objCell.Value <= .Range("L10").Value Then
                
                objCell.Interior.Color = RGB(173, 216, 230) 'light blue
                objCell.Font.Color = RGB(173, 216, 230)
                
            ElseIf objCell.Value >= .Range("K11").Value And objCell.Value <= .Range("L11").Value Then
                
                objCell.Interior.Color = RGB(106, 90, 205) 'slate blue
                objCell.Font.Color = RGB(106, 90, 205)
                
            ElseIf objCell.Value >= .Range("K12").Value And objCell.Value <= .Range("L12").Value Then
                
                objCell.Interior.Color = RGB(222, 184, 135) 'burly wood
                objCell.Font.Color = RGB(222, 184, 135)
                
            ElseIf objCell.Value >= .Range("K13").Value And objCell.Value <= .Range("L13").Value Then
                
                objCell.Interior.Color = RGB(210, 105, 30) 'chocolate
                objCell.Font.Color = RGB(210, 105, 30)
                
            ElseIf objCell.Value >= .Range("K14").Value And objCell.Value <= .Range("L14").Value Then
                
                objCell.Interior.Color = RGB(139, 69, 19) 'saddle brown
                objCell.Font.Color = RGB(139, 69, 19)
                
            ElseIf objCell.Value >= .Range("K15").Value And objCell.Value <= .Range("L15").Value Then
                
                objCell.Interior.Color = RGB(220, 20, 60) 'crimson
                objCell.Font.Color = RGB(220, 20, 60)
                
            ElseIf objCell.Value >= .Range("K16").Value And objCell.Value <= .Range("L16").Value Then
                
                objCell.Interior.Color = RGB(255, 127, 80) 'coral
                objCell.Font.Color = RGB(255, 127, 80)
                
            ElseIf objCell.Value >= .Range("K17").Value And objCell.Value <= .Range("L17").Value Then
                
                objCell.Interior.Color = RGB(255, 215, 0) 'gold
                objCell.Font.Color = RGB(255, 215, 0)
                
            ElseIf objCell.Value >= .Range("K18").Value And objCell.Value <= .Range("L18").Value Then
                
                objCell.Interior.Color = RGB(34, 139, 34) 'forest green
                objCell.Font.Color = RGB(34, 139, 34)
                
            ElseIf objCell.Value >= .Range("K19").Value And objCell.Value <= .Range("L19").Value Then
                
                objCell.Interior.Color = RGB(144, 238, 144) 'light green
                objCell.Font.Color = RGB(144, 238, 144)
                
            ElseIf objCell.Value >= .Range("K20").Value And objCell.Value <= .Range("L20").Value Then
                
                objCell.Interior.Color = RGB(0, 139, 139) 'dark cyan
                objCell.Font.Color = RGB(0, 139, 139)
                
            ElseIf objCell.Value >= .Range("K21").Value And objCell.Value <= .Range("L21").Value Then
                
                objCell.Interior.Color = RGB(238, 232, 170) 'pale golden rod
                objCell.Font.Color = RGB(238, 232, 170)
                
            ElseIf objCell.Value >= .Range("K22").Value And objCell.Value <= .Range("L22").Value Then
                
                objCell.Interior.Color = RGB(205, 92, 92) 'indian red
                objCell.Font.Color = RGB(205, 92, 92)
                
            ElseIf objCell.Value >= .Range("K23").Value And objCell.Value <= .Range("L23").Value Then
                
                objCell.Interior.Color = RGB(255, 105, 180) 'Hot Pink
                objCell.Font.Color = RGB(255, 105, 180)
                
            ElseIf objCell.Value >= .Range("K24").Value And objCell.Value <= .Range("L24").Value Then
                
                objCell.Interior.Color = RGB(0, 255, 0) 'lime
                objCell.Font.Color = RGB(0, 255, 0)
                
            ElseIf objCell.Value >= .Range("K25").Value And objCell.Value <= .Range("L25").Value Then
                
                objCell.Interior.Color = RGB(255, 255, 0) 'yellow
                objCell.Font.Color = RGB(255, 255, 0)
                
            End If
            
        Next objCell
    End With
    
    Worksheets("Overview").Protect Password:="_______"
    
    Application.ScreenUpdating = True
    
End Sub

Gruß
Nepumuk
Anzeige
AW: VBA läuft 35 sec.
07.02.2020 21:59:02
onur
"16 Regeln * 15 Zeilen = 240 Regeln ohne copy and paste.... (der Formeleditor ist hier wenig komfortabel)
" - Das liegt wohl eher an dir.
Du brauchst nur 16 Regeln (das auch nur wegen deinen vielen Farben).
Poste doch mal die Datei mit den 16 Regeln.
AW: VBA läuft 35 sec.
10.02.2020 07:33:02
Thomas
Guten Morgen Nepumuk,
hab das mal ausprobiert und muss sagen, nein leider nicht wirklich schneller. Trotzdem danke
AW: VBA läuft 35 sec.
10.02.2020 11:01:37
Nepumuk
Hallo Thomas,
komisch, bei mir dauert das Ganze keine Sekunde.
Gruß
Nepumuk
AW: VBA läuft 35 sec.
10.02.2020 13:48:54
Thomas
Ja wenn ich nur den einen Block ( K :L ) dann ja...
aber ich hab 15 Stück davon... Alle 8 Spalten bis (DS :DT)
Anzeige

Beliebteste Forumthreads (12 Monate)

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

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige