kleuren in meerdere kolommen

[rthoonsen]

Hallo, wie kan mij helpen met het volgende:

in kolom A heb ik de volgende status staan:
Reservering
Concept
Definitief
Vrijgegeven
Gereed voor uitvoering
As Built
Geaccepteerd

wanneer ik die invult dan worden kolom c t/m h gekleurd zoals tabblad status.
Dat werkt ook alleen nu zou ik dat graag op meerdere kolommen willen uitbreiden

bijvoorbeeld op kolom i, q, y en ag
dus onder kolom i, q, y en ag staan ook status en wanneer ik die daar wil aanpassen dat er ook naast deze de cellen gekleurd worden.

If Intersect(Target, Range("A:A"), Range("I:I"), Range("Q:Q"), Range("Y:Y"), Range("AG:AG")) Is Nothing Then Exit Sub

dit werkt niet en krijg dan ook een fout melding, hieronder de code voor alleen kolom A


de code is al volgt:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rGevonden As Range

'Geen verdere actie als er iets veranderd is in een andere kolom dan kolom DO.
'Deze wordt automatich gestart als er iets in kolom DO veranderd.
If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub

'Zoek in op EM in kolom A de opgegeven waarde van target.
With Sheets("Status").Range("A:A")
'Zoek naar de waarde van de cel die net is gekleurd
Set rGevonden = .Find(Target.Value, LookIn:=xlValues)
'Als waarde gevonden in de lijst dan kleur overnemen.
'Als niet gevonden dan een melding geven.
If Not rGevonden Is Nothing Then

Target.Offset(0, 2).Interior.Color = _
Sheets("Status").Range(rGevonden.Address).Offset(0, 1).Interior.Color

Target.Offset(0, 3).Interior.Color = _
Sheets("Status").Range(rGevonden.Address).Offset(0, 2).Interior.Color

Target.Offset(0, 4).Interior.Color = _
Sheets("Status").Range(rGevonden.Address).Offset(0, 3).Interior.Color

Target.Offset(0, 5).Interior.Color = _
Sheets("Status").Range(rGevonden.Address).Offset(0, 4).Interior.Color

Target.Offset(0, 6).Interior.Color = _
Sheets("Status").Range(rGevonden.Address).Offset(0, 5).Interior.Color

Target.Offset(0, 7).Interior.Color = _
Sheets("Status").Range(rGevonden.Address).Offset(0, 6).Interior.Color

Target.Offset(0, 8).Interior.Color = _
Sheets("Status").Range(rGevonden.Address).Offset(0, 7).Interior.Color
'Else
' If Target.Value <> "" Then
' MsgBox "Opgegeven code " & Target.Value & " Niet correct", vbCritical, "Foutje"
'Target.ClearContents
' End If
End If
End With
End Sub

 

[sylvester-ponte]

If Intersect(Target, Union(Range("A:A"), Range("I:I"), Range("Q:Q"), Range("Y:Y"), Range("AG:AG"))) Is Nothing Then Exit Sub

 

[rthoonsen]

ah super dank je wel