Procedure sneller uitvoeren

[AatB]

Geacht forum,

ik gebruik ondertstaande code om de kleuren van een cel te veranderen.

Het duurt circa 20 seconden om deze uit te voeren.
Weten jullie een snellere manier?

mvg,

Aat

Sub CondFormatStart()

'Put colors in Cells

Dim r, c, acc, cpe, pe, cimp, rfs1, rfs2 As Range
Dim icolor As Integer
Dim fcolor As Integer
Dim fsize As Integer
Dim fbold As Variant
Dim FName As String
Dim LastRow As Integer

    LastRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    
    For Each r In ActiveSheet.Rows(2).SpecialCells(xlCellTypeConstants)
        If r.Value = "Status" Then Set rfs1 = Range(Range(r.Address).Offset(1, 0).Address & ":" & Range(r.Address).Offset(LastRow, 0).Address)
        If r.Value = "Acc Status" Then Set acc = Range(Range(r.Address).Offset(1, 0).Address & ":" & Range(r.Address).Offset(LastRow, 2).Address)
        If r.Value = "CPE Status" Then Set cpe = Range(Range(r.Address).Offset(1, 0).Address & ":" & Range(r.Address).Offset(LastRow, 2).Address)
        If r.Value = "PE Status" Then Set pe = Range(Range(r.Address).Offset(1, 0).Address & ":" & Range(r.Address).Offset(LastRow, 2).Address)
        If r.Value = "CPE Imp Status" Then Set cimp = Range(Range(r.Address).Offset(1, 0).Address & ":" & Range(r.Address).Offset(LastRow, 2).Address)
        If r.Value = "RFS Status" Then Set rfs2 = Range(Range(r.Address).Offset(1, 0).Address & ":" & Range(r.Address).Offset(LastRow, 2).Address)
    Next r
    
    ic = 35
    acc.Interior.ColorIndex = 35
    acc.Font.ColorIndex = 1
    
    For Each c In acc
        GoSub colors
    Next c

    ic = 20
    cpe.Interior.ColorIndex = 20
    cpe.Font.ColorIndex = 1

    For Each c In cpe
        GoSub colors
    Next c
    
    ic = 28
    pe.Interior.ColorIndex = 28
    pe.Font.ColorIndex = 1
    
    For Each c In pe
        GoSub colors
    Next c
    
    ic = 37
    cimp.Interior.ColorIndex = 37
    cimp.Font.ColorIndex = 1

    For Each c In cimp
        GoSub colors
    Next c
    
    ic = 0
    rfs1.Interior.ColorIndex = 0
    rfs1.Font.ColorIndex = 1

    For Each c In rfs1
        GoSub colors
    Next c

    ic = 39
    rfs2.Interior.ColorIndex = 39
    rfs2.Font.ColorIndex = 1
 
    For Each c In rfs2
        GoSub colors
    Next c

    
    
    Exit Sub

colors:
    fcolor = 1
    icolor = ic
    
    If c.Value = "" Or _
        InStr(LCase(c.Value), "n/a") Or _
        InStr(LCase(c.Value), "cease") Or _
        InStr(LCase(c.Value), "in progress") Or _
        InStr(LCase(c.Value), "on hold") Then
        GoTo NxtColors
    End If
    
    If InStr(LCase(c.Value), "delivered") Then
        icolor = 4
    ElseIf InStr(LCase(c.Value), "snf sent") Or _
        InStr(LCase(c.Value), "cust confirmation") Or _
        InStr(LCase(c.Value), "first billing") Or _
        InStr(LCase(c.Value), "closing date") Or _
        InStr(LCase(c.Value), "closed") Then
    icolor = 36
    ElseIf InStr(LCase(c.Value), "planned") Then
        icolor = 23
    ElseIf InStr(LCase(c.Value), "ordered") Then
        icolor = 15
    ElseIf InStr(LCase(c.Value), "jeopardy") Then
        icolor = 45
    ElseIf InStr(LCase(c.Value), "critical") Or _
        InStr(LCase(c.Value), "failed") Or _
        InStr(LCase(c.Value), "not on time") Then
        icolor = 3
        fcolor = 2
    End If
NxtColors:
    c.Interior.ColorIndex = icolor
    c.Font.ColorIndex = fcolor
    Return

End Sub

 

[Ginger]

AatB, Heb je wel 'ns geprobeerd om je code via 'stap voor stap' (= F8 in je VBE) te doorlopen? Je kan dan zien hoeveel keer je code een lus moet doorlopen om tot het gewenste resultaat te komen. Wellicht kan je daar dan zelf met een goede oplossing komen.

Groet, Leo

 

[Wigi]

Aat

Ooit al van het begrip spaghetti-code gehoord?

Om eerlijk te zijn, ik loop +/- 5 jaar rond op Excel / VBA forums en ik had nog nooit van GoSub ... Return gehoord.

Niet dat dit echt de oorzaak zal zijn van het trage uitvoeren, maar goed doet het toch ook niet. Ik voel niet echt de behoeft om in deze code te gaan duiken zo zonder veel structuur.

Voor de rest: tijdelijk screenupdating uitschakelen, berekeningswijze op manueel, en vooral: ingebouwde Excel toepassing gebruiken zoals bvb. een autofilter. Tevens zo min mogelijk lussen maken en wel formules zetten die bvb. een paar condities tegelijk testen.

En denk ook aan het goed declareren van variabelen: bij

Dim r, c, acc, cpe, pe, cimp, rfs1, rfs2 As Range

is enkel rfs2 een Range, de rest zijn Variant.


Wigi

 

[AatB]

Wigi / Ginger,

bedankt voor jullie tips, ik zal ze ter harte nemen....

mvg,

Aat

 

[Wigi]

Tevens zo min mogelijk lussen maken en wel formules zetten die bvb. een paar condities tegelijk testen.

In dit opzicht is er hier een recente en nuttige methode:

http://www.worksheet.nl/forumexcel/showthread.php?t=57764

zie post # 7.

Wigi