VBA kleuren deel 2

[Roma]

Beste mensen,
Het ene probleem is opgelost maar nu stuit ik op het volgende. Ik heb een tabblad met 35 namen en enkele van deze namen wil ik een kleur geven. Deze variëren per periode. Deze kleur en naam verschijnen dan op tabblad2. Maar ik wil dit 2 maal herhalen in dezelfde kolom. (zie bijlage).
wie kan mij hierbij helpen?
bij voorbaat dank.

 

[HSV]

Het 2 maal herhalen in dezelfde kolom is me een raadsel.

Zie bijlage (uitleg staat in blad 'Namen'.

 

[Roma]

Beste Harry,
Bedankt voor je reactie. Het herhalen van de kleuren heeft te maken met de kwartalen van een jaar. Daarom komen de namen terug. Helaas worden deze in jou bijlage niet herhaald. Wat kan ik hieraan doen?

mvg Ron

 

[HSV]

Ik zie het nu pas.

Bestand aangepast in vorig schrijven.
Met een dubbelklik op de naam.

 

[Roma]

Harry,
Super het werkt als een speer. Mij vraag is wel kan deze formule op beveiligde tabbladen werken. Het is namelijk een groot betand met veel formules.

Ron

 

[HSV]

Ik neem aan dat je dan blad2 beveiligd.

Even je Blad2 beveiligen met een wachtwoord genaamd 'wachtwoord'.

Verander de code in moduleblad "Namen".

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("B12:B30,D12:D28")) Is Nothing Then
[COLOR=#FF0000]Sheets("Blad2").Unprotect "wachtwoord"[/COLOR]
 trgValue = Target.Value
   Target.Interior.Color = SelectColor(Target.Interior.Color)
  End If
   Cancel = True
 [COLOR=#FF0000]Sheets("Blad2").Protect "wachtwoord"[/COLOR]
End Sub

 

[Roma]

Harry,
Je bent een topper bedankt voor je hulp en ik heb weer wat geleerd. Nogmaals bedankt.

 

[HSV]

Graag gedaan Ron.

 

[Roma]

Harry,
Toch nog een vraag: Ik heb 4 tabbladen en allemaal in de zelfde kolom. Moet ik de module dan 4 x plaatsen met elk een andere tabbladnaam?
Ron

 

[HSV]

Nee, dat kan anders.

De beide codes.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim sh As Worksheet
If Not Intersect(Target, Range("B12:B30,D12:D28")) Is Nothing Then
Application.ScreenUpdating = False
 trgValue = Target.Value
   Target.Interior.Color = SelectColor(Target.Interior.Color)
  End If
   Cancel = True
 For Each sh In Sheets
     If Not sh.Name = ActiveSheet.Name Then
       sh.Protect "wachtwoord", , , , True
    End If
 Next sh
End Sub

Option Explicit
Public trgValue
Function SelectColor(Optional lngInitialColor As Long = 16777215) As Long
Dim lngResult As Long, lngO As Long, intR As Long, intG As Long, intB As Long, c As Range
Dim firstaddress As String
Dim sh As Worksheet
lngResult = xlNone
If Not ActiveWorkbook Is Nothing Then
    lngO = ActiveWorkbook.Colors(1)
    intR = lngInitialColor And 255
    intG = lngInitialColor \ 256 And 255
    intB = lngInitialColor \ 256 ^ 2 And 255
    If Application.Dialogs(xlDialogEditColor).Show(1, intR, intG, intB) = True Then
        lngResult = ActiveWorkbook.Colors(1)
        ActiveWorkbook.Colors(1) = lngO
    End If
End If
SelectColor = lngResult
For Each sh In Sheets
If Not sh.Name = "namen" Then
sh.Unprotect "wachtwoord"
  With sh.Columns(2)
    Set c = .Find(trgValue, , xlValues, xlWhole)
       If Not c Is Nothing Then
                firstaddress = c.Address
            c.Interior.Color = lngResult
       Do
                      Set c = .FindNext(c)
           c.Interior.Color = lngResult
        Loop While Not c Is Nothing And c.Address <> firstaddress
      End If
    End With
   End If
 Next sh
End Function

 

[Roma]

Harry
Bedankt werkt perfect zoals ik het graag wilde
Ron