Kleur cel overnemen

pasan · 14 jan 2014

probeer deze eerst even
en lees mijn zwart gedrukte teksten ook even voor de duidelijkheid

conradus · 14 jan 2014

Pasan,

reuze bedankt, ik ga 'm eens goed bekijken en hoop dat ik je nog iets mag vragen mocht dat nodig zijn.
Het lijkt je gemakkelijk af te gaan, alle lof.

conradus · 15 jan 2014

Pasan,

Het is zo bijna goed is maar ik zou heel graag dat je die rij die je buiten beschouwing hebt gelaten toch nog probeert te verwerken in het geheel.

Dus in N7:U7 worden afzonderlijk van N5:N7 ook RAL Codes ingegeven en dan zouden op N6:U6 de bijbehorende kleuren plus naam moeten komen.

N7:U7 blijft net zo lang blank totdat de RAL Code in N7 gelijk is aan N5 en dat geldt dan voor de hele rij tot U.

De rest kan zo blijven, anders gezegd zou zo moeten blijven.

Ik heb graag dat je me alleen de code stuurt en vraag je beleefd om de file in je reactie #21 te verwijderen.

conradus · 15 jan 2014

ik bedoel N7:U7 en N5:U5 in de tweede zin

pasan · 16 jan 2014

Wanneer moeten de kleuren in de tabel aangepast worden als rij 5 en 7 het zelfde zijn? of zo laten zoals het nu is?
en alleen regel 7 en 6 aanpassen zoals je hierboven heb beschreven

N7:U7 blijft net zo lang blank totdat de RAL Code in N7 gelijk is aan N5 en dat geldt dan voor de hele rij tot U.

De rest kan zo blijven, anders gezegd zou zo moeten blijven.

pasan · 16 jan 2014

probeer es

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("N7:U7")) Is Nothing Then GoTo ofdeze
If Not Intersect(Target, Range("O9:O28")) Is Nothing Then GoTo deze
If Not Intersect(Target, Range("N5:U5")) Is Nothing Then

For Each it In Range("N5:U5")
If it = "" Then it.Interior.ColorIndex = xlNone: it.Offset(-1, 0).Interior.ColorIndex = xlNone: it.Offset(-1, 0).ClearContents: it.Offset(-2, 0).Interior.ColorIndex = xlNone: Exit Sub
    With Sheets("Sheet1").Range("B4:B444")
      Set c = .Find(it, LookIn:=xlValues, LookAt:=xlWhole)
       If c Is Nothing Then it.Interior.ColorIndex = xlNone:  GoTo volgende
        it.Interior.Color = c.Interior.Color
        it.Offset(-1, 0).Interior.Color = c.Interior.Color
        it.Offset(-1, 0).Value = c.Offset(0, 9).Value
        it.Offset(-2, 0).Interior.Color = c.Interior.Color
    End With
volgende:
Next
Exit Sub

deze:
For Each it In Range("Q9:T28")
    With Sheets("Sheet1").Range("N3:U3")
      Set c = .Find(it, LookIn:=xlValues, LookAt:=xlWhole)
        it.Interior.Color = c.Interior.Color
        If it.Interior.ColorIndex = xlNone Then c.Interior.ColorIndex = xlNone
    End With
Next
Exit Sub

ofdeze:
For Each it In Range("N7:U7")
If it = "" Or it.Value <> it.Offset(-2, 0) Then it.Interior.ColorIndex = xlNone: it.Offset(-1, 0).Interior.ColorIndex = xlNone: it.Offset(-1, 0).ClearContents: it.Offset(-3, 0).ClearContents: it.Offset(-4, 0).Interior.ColorIndex = xlNone: GoTo volgen
    With Sheets("Sheet1").Range("B4:B444")
      Set c = .Find(it, LookIn:=xlValues, LookAt:=xlWhole)
       If c Is Nothing Then it.Interior.ColorIndex = xlNone: GoTo volgen
       If it.Value = it.Offset(-2, 0).Value Then
        it.Interior.Color = c.Interior.Color
        it.Offset(-1, 0).Interior.Color = c.Interior.Color
        it.Offset(-1, 0).Value = c.Offset(0, 9).Value
        it.Offset(-3, 0).Value = c.Offset(0, 9).Value
        it.Offset(-4, 0).Interior.Color = c.Interior.Color
       End If
    End With
volgen:
Next
GoTo deze
End If
End Sub

conradus · 16 jan 2014

Pasan,

Goede vraag. Vervolgens heb ik er eens goed over nagedacht en het meest optimale zou zijn dat ik voor N5:U5 een ander toepassingsbereik kan ingeven (Range) dan voor N7:U7. Ze mogen beide in real-time uitgevoerd worden. Dat zou werkelijk perfect zijn. Echt fantastisch werk. Dank je.

snb · 16 jan 2014

@pasan

Vermijd goto instructies.

Jouw eerste code herschreef ik naar:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    
    If Not Intersect(Target, Range("D6:D14")) Is Nothing Then
        With Target.Interior
            .ColorIndex = xlNone
            .Color = Cells(Application.Match(Target, Range("A1:A21"), 0), 1).Interior.Color
        End With
        
        For Each it In Range("H8:O10")
            With it.Interior
                .ColorIndex = xlNone
                .Color = Sheets("Blad1").Range("D6:D14").Find(it).Interior.Color
            End With
        Next
    End If
End Sub

pasan · 16 jan 2014

Nou heb mn best gedaan om het advies van snb toe te passen en GOTO wordt niet meer gebruikt
en ben benieuwd of deze werkt zoals je graag wilde (volgens mij wel

)
@snb bedankt voor je tips

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next

If Not Intersect(Target, Range("N5:U5")) Is Nothing Then

With Target
If Target = "" Then
Target.Interior.ColorIndex = xlNone: Target.Offset(-1, 0).Interior.ColorIndex = xlNone: Target.Offset(-2, 0).Interior.ColorIndex = xlNone: Target.Offset(-1, 0).ClearContents
    For Each it In Range("Q9:T28")
    With Sheets("Sheet1").Range("N3:U3")
      Set c = .Find(it, LookIn:=xlValues, LookAt:=xlWhole)
       If c Is Nothing Then
         .Offset(-2, 0).Interior.Color = xlNone
         .Offset(-1, 0).Interior.Color = xlNone
         .Offset(-1, 0).ClearContents
       End If
        it.Interior.Color = c.Interior.Color
        If it.Interior.ColorIndex = xlNone Then c.Interior.ColorIndex = xlNone
    End With
   Next
 Exit Sub
 End If

    With Sheets("Sheet1").Range("B4:B444")
      Set c = .Find(Target, LookIn:=xlValues, LookAt:=xlWhole)
       If c Is Nothing Then Target.Interior.ColorIndex = xlNone
       With Target
       If Target.Offset(2, 0).Value <> Target.Value Then Target.Offset(-2, 0).Interior.Color = xlNone
       If Target.Offset(2, 0) = Target Then Target.Offset(-2, 0).Interior.Color = c.Interior.Color
        .Interior.Color = c.Interior.Color
        .Offset(-1, 0).Interior.Color = c.Interior.Color
        .Offset(-1, 0).Value = c.Offset(0, 9).Value
       End With
    End With
End With
 
 For Each it In Range("Q9:T28")
    With Sheets("Sheet1").Range("N3:U3")
      Set c = .Find(it, LookIn:=xlValues, LookAt:=xlWhole)
        it.Interior.Color = c.Interior.Color
        If it.Interior.ColorIndex = xlNone Then c.Interior.ColorIndex = xlNone
    End With
 Next
End If



If Not Intersect(Target, Range("O9:O28")) Is Nothing Then
For Each it In Range("Q9:T28")
    With Sheets("Sheet1").Range("N3:U3")
      Set c = .Find(it, LookIn:=xlValues, LookAt:=xlWhole)
        it.Interior.Color = c.Interior.Color
        If it.Interior.ColorIndex = xlNone Then c.Interior.ColorIndex = xlNone
    End With
Next
Exit Sub
End If

If Not Intersect(Target, Range("N7:U7")) Is Nothing Then
If Target = "" Then
Target.Interior.ColorIndex = xlNone: Target.Offset(-1, 0).Interior.ColorIndex = xlNone: Target.Offset(-1, 0).ClearContents: Target.Offset(-4, 0).Interior.ColorIndex = xlNone
For Each it In Range("Q9:T28")
    With Sheets("Sheet1").Range("N3:U3")
      Set c = .Find(it, LookIn:=xlValues, LookAt:=xlWhole)
        it.Interior.Color = c.Interior.Color
        If it.Interior.ColorIndex = xlNone Then c.Interior.ColorIndex = xlNone
    End With
Next
 Exit Sub
End If

    With Sheets("Sheet1").Range("B4:B444")
      Set c = .Find(Target, LookIn:=xlValues, LookAt:=xlWhole)
       If c Is Nothing Then Target.Interior.ColorIndex = xlNone
       With Target
         .Offset(-1, 0).Interior.Color = xlNone
         .Offset(-1, 0).ClearContents
       If Target.Value <> Target.Offset(-2, 0).Value Then
         .Offset(-4, 0).Interior.ColorIndex = xlNone
         .Interior.Color = c.Interior.Color
         .Offset(-1, 0).Value = c.Offset(0, 9).Value
         .Offset(-1, 0).Interior.Color = c.Interior.Color
       Else
         .Interior.Color = c.Interior.Color
         .Offset(-1, 0).Interior.Color = c.Interior.Color
         .Offset(-1, 0).Value = c.Offset(0, 9).Value
         .Offset(-4, 0).Interior.Color = c.Interior.Color
       End If
      End With
    End With

For Each it In Range("Q9:T28")
    With Sheets("Sheet1").Range("N3:U3")
      Set c = .Find(it, LookIn:=xlValues, LookAt:=xlWhole)
        it.Interior.Color = c.Interior.Color
        If it.Interior.ColorIndex = xlNone Then c.Interior.ColorIndex = xlNone
    End With
Next
End If

End Sub

snb · 16 jan 2014

@pasan

Kun je svp het bestand erbij plaatsen ?

pasan · 16 jan 2014

@ snb
Ik heb je een privé bericht gestuurd want zit met een dilemma

De vraag steller wilde om redenen die mij onbekend zijn het originele bestand verwijderd hebben, en daar heb ik ook direct gehoor aan gegeven.
Mjaah hoe kan ik een vba goeroe als snb dit bestand nu weigeren, tenslotte is dit forum ervoor om van te leren

@conradus
Als je weer een excel bestand hebt die je eigenlijk niet wil posten
Probeer de volgende keer dan een voorbeeld te posten die weergeeft wat de bedoeling is zonder gevoelige info of qua layout die je voor jezelf wil houden..
En als iemand een goed stuk code kan fabriceren is het snb wel, dus hierbij zet ik het bestand er vanavond op en zal het er straks weer afhalen
verwijderd

conradus · 16 jan 2014

Pasan,

heel fijn dat je de tip van snb in de code hebt meegenomen, dank je wel.
Begrijp natuurlijk wel dat snb ook graag het bestand erbij wil hebben om het juist funktioneren van de gemaakte code beter te kunnen beoordelen.
Ik hoop ook dat jullie mijn wens om het bestand te verwijderen zullen respecteren want daar heb ik niet zo bij stilgestaan.
Bedankt voor jullie geweldige bijdrage en ik zal een volgende keer wat beter rekening houden met wat ik wel en niet wil laten zien.
Ga 'm zo testen en hou jullie op de hoogte.
Pasan ik hoop dat je 'm vanavond weer delete zoals afgesproken. snb bedankt voor je advies.

snb · 16 jan 2014

Ik heb hem gedownload. Hij kan nu dus weg.

snb · 16 jan 2014

Ik heb hem gedownload. Hij kan nu dus weg.

PS. ik kan geen PM's ontvangen.

pasan · 16 jan 2014

is verwijderd

conradus · 16 jan 2014

Pasan,

bedankt, ik bekijk 'm nog eens goed en laat je weten of die goed werkt.

snb · 17 jan 2014

@beiden

Als jullie een emailadres doorgeven via de suggestieknop op mijn website ( www.snb-vba.eu) kan ik juliie mijn aanpak in het bestand sturen.

conradus · 20 jan 2014

Het werkt super. Er zijn nog een paar dingen die ik nog graag had verwezenlijkt.

In de finale versie heb ik de tabel in een andere sheet geplaatst, "TABEL". De sheet met het kleurenschema en kleurenpatroon heeft de naam "PATRONEN".
Deze sheet heeft in z'n geheel een zwarte achtergrond en de fontkleur is wit. De Range zoals ik die nu heb omvat een groter bereik dan waarin de kleuren door het script worden aangepast, in jouw versie Q9:T28. Wat er nu echter gebeurt is dat als er per abuis een verkeerde code wordt ingegeven de cellen in die Range buiten de 'goede kleuren' WIT worden. Dat zou niet moeten. Of het zou instelbaar moeten zijn OF geen kleur.

Printopdracht via button die alleen uitgevoerd kan worden als beide kleurenrijen met elkaar overeenkomen, dus als N3

U3) gekleurd is want dan zijn de kleuren N3:N5 = N6:N7 etc.

Nu wordt in het script de 'taal' aangesproken, in ons geval dus Nederlands. Dit zou in een cel op de sheet in te stellen moeten zijn, dus welke output ze in de celkleuren willen hebben, keuze uit TABEL!C2:K2. Men krijgt dan ofwel de code's ofwel een van de talen in de kleurcellen (PATRONEN sheet) waar nu de namen staan.

snb · 20 jan 2014

Als je blijkbaar niet van plan/in staat bent deze wensen in het bestand te implementeren lijkt het me redelijk dat je degene die dat voor jou doet te betalen.
Dit forum helpt je om jou in staat te stellen iets te realiseren (helpmij.nl), het is niet bedoeld om het voor jou te doen (geefmij.nl)

conradus · 20 jan 2014

Hoi,

Heb ik dat gezegd?

Kleur cel overnemen

Terugkerende gebruiker

Gebruiker

Gebruiker

Gebruiker

Terugkerende gebruiker

Terugkerende gebruiker

Gebruiker

Verenigingslid

Terugkerende gebruiker

Verenigingslid

Terugkerende gebruiker

Gebruiker

Verenigingslid

Verenigingslid

Terugkerende gebruiker

Gebruiker

Verenigingslid

Gebruiker

Verenigingslid

Gebruiker

Wij waarderen jouw privacy