Kleur cel afhankelijk van gedefinieerde naam

[jolly01]

In de sheet heb ik namen gedefinieerd voor A,B,C,D en E.

Nou wil ik in kolom A dat als ik daar een naam plaats er automatisch de kleur verschijnt van de betreffende gedefinieerde naam.

Is dat mogelijk?

 

[roeljongman]

ja dat kan met voorwaarlijke opmaak

zet deze formule als voorwaarde voor de opmaak

=ISFOUT(VERT.ZOEKEN($A2;B;1;0))=ONWAAR

kies de kleur die hoort bij naam B in dit voorbeeld.

het bereik A2:A200 of iets wat je passend vind om deze opmaak op toe te passen

 

[zapatr]

@jolly01,
Dat is met voorw. opmaak zonder meer mogelijk in Excel 2007 en 2010, maar niet in Excel 2003 (of eerder), omdat je daarin bij voorw. opmaak slechts 3 voorwaarden kunt opnemen en jij er 5 hebt (5 verschillende kleuren). Niettemin is voor Excel 2003 ook wel een oplossing te bedenken, maar dan moet dat via vba, wat nogal bewerkelijk is.
Een opmerking terzijde: het is niet verboden, maar het is over het algemeen niet verstandig om letters die Excel als kolomnamen beschouwt (A, B, C, enz.) als bereiknamen te benoemen. Dat kan tot verwarring leiden.

@roeljongman,
Als je een celkleur wil instellen als aan een bepaalde voorwaarde is voldaan, kun je best de formule zodanig bepalen dat die waar is. Voor Excel is overigens een bewering ALTIJD waar of onwaar, die twee woorden hoef je dus bij voorw. opmaak niet te gebruiken.

Vert.zoeken is (als je met Excel 2007/2010 werkt), 1 van de mogelijkheden die je voor een oplossing kunt gebruiken, maar er zijn verschillende anderen mogelijkheden.

 

[oeldere]

VBA oplossing voor een statische reeks (zie bijlage) (tabblad Oeldere).

Sub rijen_kleuren_Oeldere()
With Worksheets("Oeldere").Range("B:B")
    Set c = .Find(what:=[n2].Value, LookIn:=xlValues, Lookat:=xlWhole)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            c.Offset(0, -1).Resize(1, 1).Interior.ColorIndex = [O2].Value
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With
End Sub

De overige kleuren zijn toegevoegd na de End With

Kolom B mag niet worden verborgen, want dan werkt de VBA code niet (getest!).

Ik heb het bestand nog niet werkend gekregen met een.

Private Sub Worksheet_Change(ByVal Target As Range)

Heb je hier vragen of opmerkingen over, laat het gewoon even weten.

Voor de duidelijkheid ook een bestand met de kleurnummers toegevoegd.

Toevoeging private sub
Ook in mijn geval kun je deze code gebruiken.
Je dient dan wel de code te plakken in het tabblad
(en niet in de module) zoals ik had gedaan (want dan werkt het niet, zoals ik ook al had aangegeven).

 

[HSV]

Sub hsv()
Dim cl As Range
 With Range("I1:M2000")
  For Each cl In Columns(1).SpecialCells(2)
  On Error Resume Next
   cl.Interior.ColorIndex = .Find(cl, , xlValues, xlWhole).Interior.ColorIndex
    Next cl
 End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cl As Range
If Not Intersect(Target, Columns(1)) Is Nothing Then
 With Range("I1:M2000")
  On Error GoTo einde
   Target.Interior.ColorIndex = .Find(Target, , xlValues, xlWhole).Interior.ColorIndex
     End With
    End If
  Exit Sub
einde:  MsgBox "Naam niet gevonden"
  Target.Interior.ColorIndex = xlNone
End Sub

Edit: Mocht de naam vaker voorkomen, dan een andere code zoals in het bestandje aangegeven.

 

[zapatr]

In de bijlage ook een vba-oplossing.
Wijzig wat in kolom A en kijk naar het resultaat.
Zoals ik in mijn eerste bericht al schreef, is een vba-oplossing veel bewerkelijker dan een met voorwaardelijke opmaak.

 

[jolly01]

Bedankt voor jullie input. De codes van HSV en zapatr is precies zoals ik het hebben wil.

In de bijlage tabblad Eport staan de originele data uit de originele sheet.

Ik heb de code van HSV overgenomen en het bereik aangepast. De invoercellen staan nu niet meer in kolom A maar in kolom M de teams staan in de kolommen AC:AG

Toch werkt de macro niet. Wat doe ik precies fout? De teams moeten als naam gedefinieerd blijven, mocht dat er mee te maken hebben.

 

[HSV]

Hierin zit het verschil.

If Not Intersect(Target, Columns([COLOR="#FF0000"]13[/COLOR])) Is Nothing Then
 With Range("AC1:AG[COLOR="#FF0000"]1[/COLOR]000")

 

[jolly01]

Ik doe kennelijk iets nog niet goed.
Heb je aanwijzingen opgevolgd maar krijg hem nog niet aan de praat.

 

[HSV]

Het is een ongeldige bijlage.

 

[jolly01]

Deze dan?

 

[HSV]

Als ik "Wouter Bos" in type, werkt het perfect, de cel wordt de gewenste kleur.

 

[jolly01]

Bij mij nu ook

De kleur van de cel verandert als ik de naam invoer.

Het werkt niet als ik in kolom M tegelijkertijd meerdere namen plak. Is het mogelijk de macro zo aan te passen dat ik in M meerdere namen kan plakken?

 

[HSV]

Ik zou 'zeggen', run code hsv.

 

[jolly01]

Helemaal top !
Ik ben erg onder de indruk. Klein dingetje nog.

In de sheet heb ik in tabblad Export de eerste 4 namen verwijderd uit kolom M. De achtergrondkleur verandert dan in wit.
Is het mogelijk dat het bereik M2:M123 die gele kleur van de cellen M82, M83 enz krijgen als er geen naam staat?

 

[HSV]

Verruil 'xlNone' voor het getal wat hier uit komt.

sub tst()
 range("m83") = range("m83").interior.colorIndex
end Sub

 

[jolly01]

Dat werkt :thumb: getal 36

Nou wil ik kolom W van tabblad Export ook net zo opmaken als kolom M.

Hoe pas ik de code aan?

 

[HSV]

Do Until teller = WorksheetFunction.CountIf(Range(Range("M2"), Target.Address), Target)
     Target.Interior.ColorIndex = c.Interior.ColorIndex
    [COLOR="#FF0000"] Target.Offset(, 10).Interior.ColorIndex = c.Interior.ColorIndex[/COLOR]
       teller = teller + 1

 

[jolly01]

Ik heb jouw toevoeging op zijn plaats gezet en macro uitgevoerd zonder resultaat.

Wat doe ik fout?

Is het overigens ook mogelijk Team1,Team2,Team3,Team4,Team5 en Team6 (het bereik C10:BX15 in de rijen 10 tot en met 15 in tabblad Eerste lijn) de corresponderende kleur te geven uit tabblad Export kolom AC:AH?

 

[HSV]

Je moet het wel overal toepassen.

Sub hsv()
Dim cl As Range, c, teller As Long
 With Range("AC1:AH1000")
  For Each cl In Columns(13).SpecialCells(2)
    On Error Resume Next
  If WorksheetFunction.CountIf(Range(Range("M2"), cl.Address), cl) > 1 Then
     teller = -1
   Set c = .Find(cl, , xlValues, xlWhole)
 Do Until teller = WorksheetFunction.CountIf(Range(Range("M2"), cl.Address), cl)
     cl.Interior.ColorIndex = c.Interior.ColorIndex
     cl.Offset(, 10).Interior.ColorIndex = c.Interior.ColorIndex
       teller = teller + 1
     Set c = .FindNext(c)
       Loop
      Else
    cl.Interior.ColorIndex = .Find(cl, , xlValues, xlWhole).Interior.ColorIndex
    cl.Offset(, 10).Interior.ColorIndex = cl.Interior.ColorIndex
   End If
  Next cl
 End With
End Sub

en.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cl As Range, teller As Long, c, firstaddress
If Not Intersect(Target, Columns(13)) Is Nothing Then
 With Range("AC1:AH1000")
  On Error GoTo einde
   If WorksheetFunction.CountIf(Range(Range("M2"), Target.Address), Target) > 1 Then
     teller = 0
   Set c = .Find(Target, , xlValues, xlWhole)
      firstaddress = c.Address
 Do Until teller = WorksheetFunction.CountIf(Range(Range("M2"), Target.Address), Target)
     Target.Interior.ColorIndex = c.Interior.ColorIndex
     Target.Offset(, 10).Interior.ColorIndex = c.Interior.ColorIndex
       teller = teller + 1
      Set c = .FindNext(c)
       Loop
      Else
    Target.Interior.ColorIndex = .Find(Target, , xlValues, xlWhole).Interior.ColorIndex
    Target.Offset(, 10).Interior.ColorIndex = Target.Interior.ColorIndex
   End If
     End With
    End If
  Exit Sub
einde:  MsgBox "Naam niet gevonden"
  Target.Interior.ColorIndex = 36
End Sub