Rijen kleuren mbv een macro zoeken

[Albatros]

Hoi,

In 3 cellen staan verschillende tijden. Nu wil ik deze tijden zoeken in kolom "C", en vervolgens de regel kleuren overeenkomstig de tijd. (begintijd blauw, eindtijd groen, starttijd koelen rood)
Dit wil ik met een macro doen niet via VO), omdat de tijden wel eens gecorrigeerd kunnen worden, en/of een andere aanvangstijd krijgen.

Dus bv in cel j2 staat een tijd van 12:55:20, de macro zoekt deze waarde op in de tabel, en kleurt de regel.
Als de regel niet gevonden wordt, mag een foutmelding verschijnen.
Ik hoop dat het duidelijk is.

Ik kom er zelf niet uit, omdat ik de waarde van bv cel j2 niet als variabele kan krijgen.

Sub rowa()
'
' rowa Macro
'

'
    Application.Goto Reference:="R12C3"
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.Goto Reference:="R10C1"
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Application.Goto Reference:="R2C10"
    ActiveCell.FormulaR1C1 = "12:55:20"
    Range("A42").Select
    Range(Selection, Selection.End(xlToRight)).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    ActiveWindow.SmallScroll Down:=-32
    Application.Goto Reference:="R4C10"
    ActiveCell.FormulaR1C1 = "13:12:20"
    Range("A93").Select
    Range(Selection, Selection.End(xlToRight)).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    Application.Goto Reference:="R7C10"
    ActiveCell.FormulaR1C1 = "13:04:40"
    Range("A70").Select
    Range(Selection, Selection.End(xlToRight)).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    Application.Goto Reference:="R11C3"
    Selection.Copy
    Range(Selection, Selection.End(xlDown)).Select
    ActiveSheet.Paste
    Application.Goto Reference:="R1C1"
    Application.CutCopyMode = False
End Sub

Alvast bedankt voor het meedenken
Albatros

 

[edmoor]

Kijk eens of je dit wat vind. De code zit in Module1 en de knop is er al aan gekoppeld. Het zou je een heel eind op weg moeten helpen.
Bekijk bijlage Rijen kleuren mbv macro zoeken.xlsm

Het kan allemaal veel compacter maar zo kan je eenvoudig lezen wat er gebeurt.

 

[HSV]

Ik had dit in gedachten voor alleen J2.

Sub hsv()
Dim x
  x = Application.Match([j2], Columns(3), 0)
If Not IsError(x) Then Cells(x, 1).Resize(, 9).Interior.Color = vbYellow
End Sub

 

[Albatros]

Heren,

Super bedankt! beide oplossingen werken perfect.
Ik begrijp de opbouw niet helemaal, maar ik kan weer vooruit!

Bedankt!

Albatros,

 

[Albatros]

Toch nog even een vraag,
De macro van edmoor kleurt de hele rij, die van HSV kleurt tot regel 9.
De breedte van de tabel wisselt. Als ik alleen de breedte van de cellen wil kleuren, lukt dat niet door "entireRow of "9" te vervangen door end. Het zal wel te simpel gedacht zijn van mij, maar is hier nog een aanvulling op?

Albatros

 

[HSV]

If Not IsError(x) Then Cells(x, 1).Resize(, Cells(x, Columns.Count).End(xlToLeft).Column).Interior.Color = vbYellow

 

[Albatros]

Beste HSV,

Bedankt voor de aanpassing. Echter bij de kleuren "rood" en "blauw" zijn de cellen niet meer leesbaar.
Met jouw suggestie wil ik nu de macro aanpassen van Edmoor. Misschien te eenvoudig gedacht, maar met onderstaande krijg ik een foutmelding.:

Sub RijenKleuren()
    Dim LR As Long
    Dim i As Long
    
    Dim StartTijd As Date
    Dim EindTijd As Date
    Dim KoelTijd As Date
    
    Dim StartKleur As Long
    Dim EindKleur As Long
    Dim Koelkleur As Long
    
    StartTijd = Range("J2")
    EindTijd = Range("J4")
    KoelTijd = Range("J7")
    
    StartKleur = Range("J2").Interior.Color
    EindKleur = Range("J4").Interior.Color
    Koelkleur = Range("J7").Interior.Color
    
    With ActiveSheet
        LR = .Cells(.Rows.Count, "C").End(xlUp).Row
    End With
    
    For i = 11 To LR
        Select Case Cells(i, 3).Value
            Case StartTijd: Cells(i, 1).( Cells(x, Columns.Count).End(xlToLeft).Column).Interior.Color = StartKleur
            Case EindTijd:  Cells(i, 1).EntireRow.Interior.Color = EindKleur
            Case KoelTijd:  Cells(i, 1).EntireRow.Interior.Color = Koelkleur
        End Select
    Next i
End Sub

(Sorry moderator, ik had deze topic al afgesloten, maar wil de puntjes nog even op de "i" krijgen)

Albatros

 

[edmoor]

Als je zegt een foutmelding te krijgen is het wel zo handig erbij te vermelden welke dat is en op welke regel in de code dat gebeurd.

Aan de andere kant, je hebt het voorbeeld van HSV totaal verkeerd toegepast.

 

[VenA]

Ik zie nergens dat x een waarde krijgt.

mogelijk

Case StartTijd: Cells(i, Columns.Count).End(xlToLeft).Interior.Color = StartKleur

 

[HSV]

Mogelijk iets beter.

Case StartTijd: range(cells(i, 1), Cells(i, Columns.Count).End(xlToLeft)).Interior.Color = StartKleur

 

[Albatros]

Yes!

Met de laatste aanpassing ben ik er helemaal uit :thumb:
Bedankt voor het meedenken, en aanvullen van mijn kennis.

Albatros