Microsoft Excel

Herbers Excel/VBA-Archiv

VBA läuft 35 sec.

Betrifft: VBA läuft 35 sec. von: Thomas
Geschrieben am: 07.02.2020 14:07:09

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("L9") Then
            cell.Interior.Color = RGB(0, 191, 255) 'deep sky blue
            cell.Font.Color = cell.Interior.Color
        End If

        If cell >= Worksheets("Milestone").Range("K10") And cell <= Worksheets("Milestone"). _
Range("L10") Then
            cell.Interior.Color = RGB(173, 216, 230) 'light blue
            cell.Font.Color = cell.Interior.Color
        End If

        If cell >= Worksheets("Milestone").Range("K11") And cell <= Worksheets("Milestone"). _
Range("L11") Then
            cell.Interior.Color = RGB(106, 90, 205) 'slate blue
            cell.Font.Color = cell.Interior.Color
        End If

        If cell >= Worksheets("Milestone").Range("K12") And cell <= Worksheets("Milestone"). _
Range("L12") Then
            cell.Interior.Color = RGB(222, 184, 135) 'burly wood
            cell.Font.Color = cell.Interior.Color
        End If

        If cell >= Worksheets("Milestone").Range("K13") And cell <= Worksheets("Milestone"). _
Range("L13") Then
            cell.Interior.Color = RGB(210, 105, 30) 'chocolate
            cell.Font.Color = cell.Interior.Color
        End If

        If cell >= Worksheets("Milestone").Range("K14") And cell <= Worksheets("Milestone"). _
Range("L14") Then
            cell.Interior.Color = RGB(139, 69, 19) 'saddle brown
            cell.Font.Color = cell.Interior.Color
        End If

        If cell >= Worksheets("Milestone").Range("K15") And cell <= Worksheets("Milestone"). _
Range("L15") Then
            cell.Interior.Color = RGB(220, 20, 60) 'crimson
            cell.Font.Color = cell.Interior.Color
        End If

        If cell >= Worksheets("Milestone").Range("K16") And cell <= Worksheets("Milestone"). _
Range("L16") Then
            cell.Interior.Color = RGB(255, 127, 80) 'coral
            cell.Font.Color = cell.Interior.Color
        End If

        If cell >= Worksheets("Milestone").Range("K17") And cell <= Worksheets("Milestone"). _
Range("L17") Then
            cell.Interior.Color = RGB(255, 215, 0) 'gold
            cell.Font.Color = cell.Interior.Color
        End If

        If cell >= Worksheets("Milestone").Range("K18") And cell <= Worksheets("Milestone"). _
Range("L18") Then
            cell.Interior.Color = RGB(34, 139, 34) 'forest green
            cell.Font.Color = cell.Interior.Color
        End If

        If cell >= Worksheets("Milestone").Range("K19") And cell <= Worksheets("Milestone"). _
Range("L19") Then
            cell.Interior.Color = RGB(144, 238, 144) 'light green
            cell.Font.Color = cell.Interior.Color
        End If

        If cell >= Worksheets("Milestone").Range("K20") And cell <= Worksheets("Milestone"). _
Range("L20") Then
            cell.Interior.Color = RGB(0, 139, 139) 'dark cyan
            cell.Font.Color = cell.Interior.Color
        End If

        If cell >= Worksheets("Milestone").Range("K21") And cell <= Worksheets("Milestone"). _
Range("L21") Then
            cell.Interior.Color = RGB(238, 232, 170) 'pale golden rod
            cell.Font.Color = cell.Interior.Color
        End If

        If cell >= Worksheets("Milestone").Range("K22") And cell <= Worksheets("Milestone"). _
Range("L22") Then
            cell.Interior.Color = RGB(205, 92, 92) 'indian red
            cell.Font.Color = cell.Interior.Color
        End If

        If cell >= Worksheets("Milestone").Range("K23") And cell <= Worksheets("Milestone"). _
Range("L23") Then
            cell.Interior.Color = RGB(255, 105, 180) 'Hot Pink
            cell.Font.Color = cell.Interior.Color

        End If

        If cell >= Worksheets("Milestone").Range("K24") And cell <= Worksheets("Milestone"). _
Range("L24") Then
            cell.Interior.Color = RGB(0, 255, 0) 'lime
            cell.Font.Color = cell.Interior.Color
        End If

        If cell >= Worksheets("Milestone").Range("K25") And cell <= Worksheets("Milestone"). _
Range("L25") Then
            cell.Interior.Color = RGB(255, 255, 0) 'yellow
            cell.Font.Color = cell.Interior.Color

        End If

    Next cell
'=============================================================================================== _
===================
                                                                                             .
                                                                                             .
                                                                                             .
                                                                                             .
                                                                                             .
                                                                                             .

    Worksheets("Overview").Protect Password:="_______"
End Sub

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 <= Worksheets("Milestone").Range("L9") Then
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<=Milestone!$L$9)

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<= L9 Then färbe mir Zelle B7 ein... (hier bin ich gescheitert... kläglich)

Also hab ich den Zeitstrahl in jetzt 16 Zeilen stehen, gefällt mir nicht... aber irgendwas is ja immer....

Betrifft: Crossposting
von: SF
Geschrieben am: 07.02.2020 14:23:27

http://www.office-loesung.de/p/viewtopic.php?f=166&t=829534

Gruß,
steve1da

Betrifft: AW: VBA läuft 35 sec.
von: Nepumuk
Geschrieben am: 07.02.2020 15:27:23

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

Betrifft: AW: VBA läuft 35 sec.
von: onur
Geschrieben am: 07.02.2020 21:59:02

"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.

Betrifft: AW: VBA läuft 35 sec.
von: Thomas
Geschrieben am: 10.02.2020 07:33:02

Guten Morgen Nepumuk,

hab das mal ausprobiert und muss sagen, nein leider nicht wirklich schneller. Trotzdem danke

Betrifft: AW: VBA läuft 35 sec.
von: Nepumuk
Geschrieben am: 10.02.2020 11:01:37

Hallo Thomas,

komisch, bei mir dauert das Ganze keine Sekunde.

Gruß
Nepumuk

Betrifft: AW: VBA läuft 35 sec.
von: Thomas
Geschrieben am: 10.02.2020 13:48:54

Ja wenn ich nur den einen Block ( K :L ) dann ja...

aber ich hab 15 Stück davon... Alle 8 Spalten bis (DS :DT)