[Excel VBA] Colorindex

[Anoniem: 357252]

Hallo allemaal,

Ik heb een gedeelde excelbestand waarin de gebruikers hun rooster aan kunnen geven met behulp van cijfers. Bij het vullen van het rooster neem het rooster van de gebruiker een kleur aan van de activiteit. Ik heb tot zover de volgende VBA code in het werkblad dat de kleur aanneemt van de activiteit.

VBScript:

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:AZ95")) Is Nothing Then
With Target
    Select Case .Value
        Case Is = "0"
            .Interior.ColorIndex = 35
        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 Is = "9"
            .Interior.ColorIndex = 43
        Case Else
            .Interior.ColorIndex = xlNone
    End Select
End With
End If
Multi:
Selection.Interior.ColorIndex = xlNone
End Sub

De cel neemt de kleur aan van de activiteit met de code en wordt blank bij het verwijderen van de cijfer, tot zover verloopt het nog goed. Alleen ik loop tegen het volgende aan: Als een gebruiker een cijfer invult en vervolgens op enter of de pijltjes toets gebruikt, dan wordt de cel die al een activiteit aangeeft na het intoetsen van de toest blank, dit zou niet moeten gebeuren. Als er geen activiteit wordt ingevuld en de pijltjes toest en de enter knop wordt gebruik dan werkt het rooster wel naar wens. Verder als de gebruiker de cellen wil kopieren en deze wil plakken, nemen de cijfers niet de bijbehorende kleur van de activiteit aan, terwijl dit wel de bedoeling moet zijn.

Hoe kan ik ervoor zorgen dat bij het gebruiken van de pijltjes toest en de enter knop bij het vullen van de activiteit de al gevulde cel onveranderd laat en dat de gebruiker cellen kan kopieren en bij het plakken de kleur van de activiteit wordt aangenomen.

Ik hoop dat ik het enigzins duidelijk uit heb kunnen leggen en dat iemand mij hiermee verder kan helpen. Alvast bedankt

[Anoniem: 113297]

voor het eerste van de in italics aangegeven problemen moet er andere code zijn die dit wijzigt, want de code in je post verandert niets aan de inhoud van een cel.
wat betreft je tweede probleem : wegens de gekopieerde cellen heb je eigenlijk een mutiselectie zoals jij het in je code noemt. als je daar terecht komt moet er een bijkomende test gebeuren op de cutcopymode eigenschap. indien het gekopieerde bereik activiteiten betreft, dan moet in het doelbereik de overeenstemmende kleuren ingevuld worden, indien anders, gewoon kopiëren.

[Anoniem: 357252]

Anoniem: 113297 schreef op maandag 19 juli 2010 @ 11:45:
voor het eerste van de in italics aangegeven problemen moet er andere code zijn die dit wijzigt, want de code in je post verandert niets aan de inhoud van een cel.

Hallo hereatic, ik begrijp niet goed wat je bedoeld, bedoel je dat de code helemaal niet verandert bij het invoeren van een cijfer?, dit doet ie namelijk wel of bedoelde je iets anders?

Ik heb de code nu enigzins aangepast, de code is nu als volgt:

VBScript:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If [A1] = 1 Then Exit Sub
Target.Interior.ColorIndex = xlNone
If Not Intersect(Target, Range("A5:AZ95")) Is Nothing And Target.Value <> "" Then Target.Interior.ColorIndex = Choose(Target.Value + 1, 35, 8, 6, 3, 4, 48, 39, 7, 40, 43)
With Target
    Select Case .Value
        Case Is = "0"
            .Interior.ColorIndex = 35
        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 Is = "9"
            .Interior.ColorIndex = 43
    End Select
End With

End Sub

Het eerste probleem heb ik nu kunnen oplossen, namelijk dat de cel onveranderd blijft bij het gebruiken van de enter- en pijltjes toest.


Het tweede probleem met het kopieer en plakken heb ik nog niet op kunnen lossen. Bij het plakken
krijg ik namelijk de foutmelding 13 en blijft de VBA code op de volgende regel hangen:

VBScript:

If Not Intersect(Target, Range("A5:AZ95")) Is Nothing And Target.Value <> "" Then Target.Interior.ColorIndex = Choose(Target.Value + 1, 35, 8, 6, 3, 4, 48, 39, 7, 40, 43)

Bovendien krijg ik bij de nieuwe code een probleem bij, namelijk bij het verwijderen van de inhoud van meerdere cellen tegelijkertijd, moeten de kleur van de cellen weer blank worden, dit gebeurd wel, maar pas op het moment dat ik op stopknop klik bij de foutmelding zoals boven staat beschreven:

hopelijk dat jullie mij hiermee verder kunnen helpen
alvast bedankt

[Reptile209]

offtopic:
Zitten de S en de T omgedraaid op je "toeSTenbord"?

Volgens mij doe je nu in je aangepaste code twee keer hetzelfde:

Visual Basic:

Target.Interior.ColorIndex = Choose(Target.Value + 1, 35, 8, 6, 3, 4, 48, 39, 7, 40, 43)

en

Visual Basic:

With Target 
    Select Case .Value 
        Case Is = "0" 
            .Interior.ColorIndex = 35 
...

doen volgens mij hetzelfde. Overigens heb je in beide gevallen geen 'else'-variant meer, voor het geval dat ik bijvoorbeeld 11 invul.

Kan je de multi-cel selectie case niet oplossen met een loopje? Pak je Target, wandel één voor één door de gewijzigde cellen heen en pas de kleur aan.

[Anoniem: 357252]

Reptile209 schreef op maandag 19 juli 2010 @ 18:37:

Volgens mij doe je nu in je aangepaste code twee keer hetzelfde:

Je hebt helemaal gelijk. thx
Ik heb t aangepast:

VBScript:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If [A1] = 1 Then Exit Sub
Target.Interior.ColorIndex = xlNone
If Not Intersect(Target, Range("A5:AZ95")) Is Nothing And Target.Value <> "" Then Target.Interior.ColorIndex = Choose(Target.Value + 1, 35, 8, 6, 3, 4, 48, 39, 7, 40, 43)
End Sub

Kan je de multi-cel selectie case niet oplossen met een loopje? Pak je Target, wandel één voor één door de gewijzigde cellen heen en pas de kleur aan.

In het begin had ik de code zo dat deze alle aangeven cellen doorliep, alleen dit werkte heel traag en was niet wenselijk voor de gebruikers
oude code:

VBScript:

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: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

[Reptile209]

Anoniem: 357252 schreef op dinsdag 20 juli 2010 @ 08:38:
[...]


Je hebt helemaal gelijk. thx
Ik heb t aangepast:

VBScript:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If [A1] = 1 Then Exit Sub
Target.Interior.ColorIndex = xlNone
If Not Intersect(Target, Range("A5:AZ95")) Is Nothing And Target.Value <> "" Then Target.Interior.ColorIndex = Choose(Target.Value + 1, 35, 8, 6, 3, 4, 48, 39, 7, 40, 43)
End Sub

Ik zou denk ik voor de Select Case versie zijn gegaan, omdat je dan een 'else' kunt gebruiken. Ik weet niet wat Choose doet als je 'm nu 42 als waarde zou meegeven in Target.Value. En het leest wat sneller, en je hoeft niet te tellen welke 'case' welke waarde krijgt .

[...]


In het begin had ik de code zo dat deze alle aangeven cellen doorliep, alleen dit werkte heel traag en was niet wenselijk voor de gebruikers
oude code:

VBScript:

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:A95:AZ95]
With x

    Select Case UCase(.Value)
...

Als je begint met

Visual Basic .NET:

Application.ScreenUpdating = False

dan loopt het al een stuk sneller. Niet vergeten om hem aan het eind van je macro weer op True te zetten (!).
Daarnaast hoef je niet je hele sheet door te wandelen, maar alleen de range van Target. Dat moet ook wel behoorlijk schelen.

[Anoniem: 357252]

Reptile209 schreef op dinsdag 20 juli 2010 @ 09:44:

Als je begint met

Visual Basic .NET:

Application.ScreenUpdating = False

dan loopt het al een stuk sneller. Niet vergeten om hem aan het eind van je macro weer op True te zetten (!).
Daarnaast hoef je niet je hele sheet door te wandelen, maar alleen de range van Target. Dat moet ook wel behoorlijk schelen.

Ja dat klopt, maar werkte helaas nog niet goed. Ik heb inmiddels wel een oplossing gevonden

VBScript:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
  If [A1] = 1 Then Exit Sub
  Target.Interior.ColorIndex = xlNone
  If Not Intersect(Target, Range("A5:AZ95")) Is Nothing Then
    For Each tg In Target
      If tg.Value <> "" Then tg.Interior.ColorIndex = Choose(tg.Value + 1, 35, 8, 6, 3, 4, 48, 39, 7, 40, 43)
    Next
  End If
End Sub

[Anoniem: 147180]

Als ik dan nog wat codegerelateerde tips mag geven

• Declareer tg als Range;
• Geef expliciet aan dat "Range("A95:AZ95")" bij de betreffende worksheet hoort met "Me.Range("...")";
• ipv "Square bracket notation" kun je beter "Me.Range("A1")" gebruiken;
• ipv "If [A1]=1 then exit sub" zou ik schrijven "If Me.Range("A1") <> 1 Then ... End if" met in het if-block de uitvoerbare code.

Hangt ook een beetje van je persoonlijke voorkeuren af natuurlijk.

[Anoniem: 357252]

Anoniem: 147180 schreef op dinsdag 20 juli 2010 @ 12:56:
Als ik dan nog wat codegerelateerde tips mag geven

• Declareer tg als Range;
• Geef expliciet aan dat "Range("A95:AZ95")" bij de betreffende worksheet hoort met "Me.Range("...")";
• ipv "Square bracket notation" kun je beter "Me.Range("A1")" gebruiken;
• ipv "If [A1]=1 then exit sub" zou ik schrijven "If Me.Range("A1") <> 1 Then ... End if" met in het if-block de uitvoerbare code.

Hangt ook een beetje van je persoonlijke voorkeuren af natuurlijk.

Bedankt voor de tips , ik ga kijken of ik hier ook nog iets mee kan doen