VBA code sneller later werken

[uchhie]

Hallo allemaal,

Bij het vullen van een cel van een bepaald cijfer in een excelbestand wordt de cel gekleurd. Ik heb hiervoor een VBA code gevonden op het internet die ervoor zorgt dat meer dan 3 kleuren kunt gebruiken zoals bij de voorwaardelijke opmaak.
Alleen werkt de code niet echt snel, weet iemand hoe ik deze code sneller kan laten werken. Overigens niet onbelangrijk het excelbestand is een gedeeld bestand waar meerdere gebruikers in werken en zijn circa 50 werkbladen. De volgende code heb ik gebruikt:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If [A1] = 1 Then Exit Sub
Dim x As Range
For Each x In ActiveSheet.[A5:AZ5:A20:az20:A35:az35:A50:az50:A65:az65:A80:az80:A95:az95]
With x

    Select Case UCase(.Value)
    
    Case Is = "1"
        .Interior.ColorIndex = 8
    Case Is = "2"
        .Interior.ColorIndex = 6
    Case Is = "3"
        .Interior.ColorIndex = 3
    Case Is = "4"
        .Interior.ColorIndex = 4
    Case Is = "5"
        .Interior.ColorIndex = 48
    Case Is = "6"
        .Interior.ColorIndex = 39
    Case Is = "7"
        .Interior.ColorIndex = 7
    Case Is = "8"
        .Interior.ColorIndex = 40
    Case Else
        .Interior.ColorIndex = xlNone
       
    End Select
    End With
Next
End Sub

Alvast bedankt

 

[ronald1986]

Je kunt screenupdating uitzetten...
Dan krijg je zoiets als dit:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Excel.Range)

Application.ScreenUpdating = False
If [A1] = 1 Then Exit Sub
Dim x As Range
For Each x In ActiveSheet.[A5:AZ5:A20:az20:A35:az35:A50:az50:A65:az65:A80:az80:A95:az95]
With x

    Select Case UCase(.Value)
    
    Case Is = "1"
        .Interior.ColorIndex = 8
    Case Is = "2"
        .Interior.ColorIndex = 6
    Case Is = "3"
        .Interior.ColorIndex = 3
    Case Is = "4"
        .Interior.ColorIndex = 4
    Case Is = "5"
        .Interior.ColorIndex = 48
    Case Is = "6"
        .Interior.ColorIndex = 39
    Case Is = "7"
        .Interior.ColorIndex = 7
    Case Is = "8"
        .Interior.ColorIndex = 40
    Case Else
        .Interior.ColorIndex = xlNone

Application.ScreenUpdating = True
       
    End Select
    End With
Next
End Sub

 

[WHER]

Of probeer eens met:

For Each x In ActiveSheet.[A5:AZ5[COLOR="red"],[/COLOR]A20:az20[COLOR="red"], [/COLOR]etc]

 

[uchhie]

Je kunt screenupdating uitzetten...

Ronald bedankt voor je reactie, ik heb de screenupdating toegevoegd, alleen duurt het verwerken nog langer. Het scherm begint dan te flikkeren, dit lijkt me niet goed

 

[uchhie]

Of probeer eens met:

For Each x In ActiveSheet.[A5:AZ5[COLOR="red"],[/COLOR]A20:az20[COLOR="red"], [/COLOR]etc]

Bedankt voor je reactie WHER, als ik de dubbele punten vervang door een comma dan werkt de code niet meer.
Ik heb de volgende regel als volgt aangepast

For Each x In ActiveSheet.[A5:AZ5:A95:AZ95]

Helaas lost dit ook het probleem niet op; Bij elke nieuwe invoer moet ik wachten om opnieuw iets in te kunnen voeren

Het lijkt net of bij elke nieuwe invoer het bestand op gaat slaan

 

[Ginger]

Helaas heb ik niet meer tijd om je verder te helpen met aanpassingen in je code, maar heb wel ff een momentje voor deze reactie op je vraag....
Het probleem zit 'm in het feit dat je bij ELKE change op je sheet door ALLE aangegeven cellen gaat lopen om daar een check uit te voeren en te kleuren. Je moet dus je controle beperken tot de 'target' en alleen dáár je aanpassing op maken. Als het ff tegenzit schiet de code zelfs nog in een lus omdat die zichzelf aanroept (maar deze laatste opmerkijng kan ik in de haast ook mis hebben).

Groet, Leo

 

[gelens]

Uchhie

Ik heb de volgende regel toegevoegd :

set x = target

Hierdoor kijkt de code alleen naar de gewijzigde cel.
Het For each gedeelte heb ik geblokt.

Volgens mij werkt het nu prima. Maar wel voor het gehele sheet.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If [A1] = 1 Then Exit Sub
Dim x As Range
[B][COLOR="red"]Set x = Target[/COLOR][/B]

'For Each x In ActiveSheet.[A5:AZ5:A20:az20:A35:az35:A50:az50:A65:az65:A80:az80:A95:az95]
With x

    Select Case UCase(.Value)
    
    Case Is = "1"
        .Interior.ColorIndex = 8
    Case Is = "2"
        .Interior.ColorIndex = 6
    Case Is = "3"
        .Interior.ColorIndex = 3
    Case Is = "4"
        .Interior.ColorIndex = 4
    Case Is = "5"
        .Interior.ColorIndex = 48
    Case Is = "6"
        .Interior.ColorIndex = 39
    Case Is = "7"
        .Interior.ColorIndex = 7
    Case Is = "8"
        .Interior.ColorIndex = 40
    Case Else
        .Interior.ColorIndex = xlNone
       
    End Select
    End With
'Next Verwijderen
End Sub

 

[uchhie]

Opgelost

Zoals Leo het beschreef en zoals gelens het prachtig aanvult is het gelukt, bedankt jongens:d

 

[uchhie]

Ik juichde iets te vroeg. De code werkt zekers sneller, alleen als ik de inhoud van een aantal cellen wil verwijderen krijg ik een foutcode "13" en de code blijft hangen op de volgende regel:

 Select Case UCase(.Value)

Ik wil graag proberen bij het wissen van de inhoud dat ook de kleur weer terug wordt gezet, dit gebeurd wel als ik de inhoud van 1 cel verwijderen, maar niet bij meerdere cellen tegelijkertijd, zoals dit wel gebeurde bij de oude code

 

[Warme bakkertje]

Zo werkt de code enkel voor je gewenste bereiken, kan je meerdere cellen tegelijkertijd verwijderen en wordt de kleur teruggezet

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If [A1] = 1 Then Exit Sub
If Target.Count > 1 Then GoTo Multi:
If Not Intersect(Target, Range("A5:AZ5,A20:AZ20,A35:AZ35,A50:AZ50,A65:AZ65,A80:AZ80,A95:AZ95")) Is Nothing Then
With Target
    Select Case .Value
        Case Is = "1"
            .Interior.ColorIndex = 8
        Case Is = "2"
            .Interior.ColorIndex = 6
        Case Is = "3"
            .Interior.ColorIndex = 3
        Case Is = "4"
            .Interior.ColorIndex = 4
        Case Is = "5"
            .Interior.ColorIndex = 48
        Case Is = "6"
            .Interior.ColorIndex = 39
        Case Is = "7"
            .Interior.ColorIndex = 7
        Case Is = "8"
            .Interior.ColorIndex = 40
        Case Else
            .Interior.ColorIndex = xlNone
    End Select
End With
End If
Multi:
Selection.Interior.ColorIndex = xlNone
End Sub

 

[uchhie]

Nu echt opgelost

Super! dat is precies wat ik bedoelde. bedankt warme bakkertje voor het meedenken:thumb: