VBA - color the task, which has been sign by X

[maxblack]

Hello Collegues,

I need your help following idea. I have a table with employees where I insert, what they will be doing particular day. To make it more readable I have following idea:

When Perons 1 will choose her name, cells in row 2, where we have tasks, which have to done will be coloured. Which task should be coloured should be based on X inserted in row of that person. I try to figure it out how to do this using VBA.

I would be grateful for your support.
Thanks
max

21/04/2017

Task 1

Task 2

Task 3

Task 4

Task 5

Task 6

Task 7

Task 8

Task 9

Task 10

Task 11

Task 12

Task 13

Task 14

Task 15

P1

X

P2

X

X

P3

X

X

X

P4

X

X

X

P5

X

X

X

P6

X

X

P7

X

X

P8

X

X

P9

X

X

P10

X

X

P11

X

X

P12

X

X

<tbody>
</tbody>

I had no ide how to attach something.

 

[MickG]

Try this:-
NB:- This code will work for individual tables as long as there is a Blank row between them.

Private [COLOR="Navy"]Sub[/COLOR] Worksheet_SelectionChange(ByVal Target [COLOR="Navy"]As[/COLOR] Range)
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, R [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]If[/COLOR] Not Intersect(Target, Columns("A:A")) [COLOR="Navy"]Is[/COLOR] Nothing And Target.Count = 1 [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]Set[/COLOR] Rng = Target.CurrentRegion
        Rng.Interior.ColorIndex = xlNone
    Target.Offset(, 1).Resize(, Rng.Columns.Count).SpecialCells(xlCellTypeConstants).Interior.Color = vbYellow
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[maxblack]

MickG, yes it working good, I guess that to highlight not X but the header i have to change something in offset? also as I wrote in previouse post its changing the color of whole table
I would like to do not change table colors into white, so I thik that maybe I will set for example orange color for headers and it will be highlighting and then changing back to orange?

 

[MickG]

I have altered the code so that it now does not change the Header row or column "A" colours.
I am assuming that the range areas within the headers and column "A" do not have a colour and will be change to "XlNone" on re-selection.
If they do in actual fact have a separate colour which you would like to retain, let me know what the colour is and I'll alter the code.

Private [COLOR="Navy"]Sub[/COLOR] Worksheet_SelectionChange(ByVal Target [COLOR="Navy"]As[/COLOR] Range)
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, R [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]If[/COLOR] Not Intersect(Target, Columns("A:A")) [COLOR="Navy"]Is[/COLOR] Nothing And Target.Count = 1 [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]Set[/COLOR] Rng = Target.CurrentRegion
        Rng.Offset(1, 1).Interior.ColorIndex = xlNone
    Target.Offset(, 1).Resize(, Rng.Columns.Count).SpecialCells(xlCellTypeConstants).Interior.Color = vbYellow
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[maxblack]

Thanks Mick, find below the simple screen how it will look like more less. When I select Person 1 then I would like to see highlighted header Task1 and Task 3. Then when somebody else (file shared) will select Person 3 then Task 1 and Task 3 will be highlighted etc.

Currently in your code I see that only X cells are highlighted.

I would like to stay with colours as it is, so blue task 1 is going to be highlighted into yellow but then its going back to blue.

Code of Nishant94 is highliting headers as it should be, but there is also problem with table colours - its clearing whole table to white.

Thanks for your support!

 

[Nishant94]

Maybe something like this:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)


On Error Resume Next
Application.ScreenUpdating = False


    Dim MatrixRng As Range, DataRange As Range
    Dim LastColumn As Integer, icounter As Integer
    Dim Rng As Range, Rng2 As Range


    Set Rng = Target.End(xlUp)
    If Rng.Value = Target.Value Then Exit Sub
    LastColumn = Range(Rng, Rng.End(xlToRight)).Cells.Count
    If IsDate(Rng.Value) Then
        For icounter = 1 To LastColumn
            If Rng.Offset(0, icounter).Interior.Color <> vbYellow Then
                Rng.Offset(0, icounter).Copy
                GoTo NextSection
            End If
        Next icounter
        
NextSection:
        
        Range(Rng.Offset(0, 1), Rng.Offset(0, LastColumn - 1)).PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
        Application.EnableEvents = False
        Target.Select
        Application.EnableEvents = True
        Set MatrixRng = Range(Rng, Rng.End(xlDown))
         If Not Intersect(Target, MatrixRng) Is Nothing Then
            Set DataRange = Range(Target.Offset(0, 1), Target.Offset(0, LastColumn))
            For Each Rng2 In DataRange
                If Not IsEmpty(Rng2) Then
                    Rng2.Offset(-Rng2.Row + Rng.Row, 0).Interior.Color = vbYellow
                End If
            Next Rng2
         End If
    End If
Application.ScreenUpdating = True
End Sub

This should solve all the questions you asked.

 

[maxblack]

Nishant94 - its working perfectly! Thanks!

Only one thing, where i should add line inside code, which will be clear highlight if I select A1 cell?

 

[Nishant94]

Private Sub Worksheet_SelectionChange(ByVal Target As Range)


On Error Resume Next
Application.ScreenUpdating = False


    Dim MatrixRng As Range, DataRange As Range, check As Boolean
    Dim LastColumn As Integer, icounter As Integer
    Dim Rng As Range, Rng2 As Range


    Set Rng = Target.End(xlUp)


    If IsDate(Target.Value) Then
        icounter = 1
        Do Until icounter = LastColumn Or check = True
            If Target.Offset(0, icounter).Interior.Color <> vbYellow Then
                check = True
                Target.Offset(0, icounter).Copy
            End If
            icounter = icounter + 1
        Loop
        Range(Target.Offset(0, 1), Target.End(xlToRight)).PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
        Application.EnableEvents = False
        Target.Select
        Application.EnableEvents = True
        Exit Sub
    End If
    LastColumn = Range(Rng, Rng.End(xlToRight)).Cells.Count
    If IsDate(Rng.Value) Then
        icounter = 1
        Do Until icounter = LastColumn Or check = True
            If Rng.Offset(0, icounter).Interior.Color <> vbYellow Then
                check = True
                Rng.Offset(0, icounter).Copy
            End If
            icounter = icounter + 1
         Loop
        Range(Rng.Offset(0, 1), Rng.Offset(0, LastColumn - 1)).PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
        Application.EnableEvents = False
        Target.Select
        Application.EnableEvents = True
        Set MatrixRng = Range(Rng, Rng.End(xlDown))
         If Not Intersect(Target, MatrixRng) Is Nothing Then
            Set DataRange = Range(Target.Offset(0, 1), Target.Offset(0, LastColumn))
            For Each Rng2 In DataRange
                If Not IsEmpty(Rng2) Then
                    Rng2.Offset(-Rng2.Row + Rng.Row, 0).Interior.Color = vbYellow
                End If
            Next Rng2
         End If
    End If
Application.ScreenUpdating = True
End Sub

 

[maxblack]

Nishant94 you are amazing - thank you! its working perfectly!

If I will transponse my table and persons will be in top row and tasks in column A, what I have to modify in code? Becouse I think it could be more readable.

 

[maxblack]

Like this:

	Person 1	Person 2	Person 3	Person 4
Task 1			X
Task 2	X	X
Task 3		X
Task 4				X
Task 5		X
Task 6				X

<tbody>
</tbody>

I hope that you could help me with that and it will be my last request

Thanks

 

[Nishant94]

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

On Error Resume Next
Application.ScreenUpdating = False


    Dim MatrixRng As Range, DataRange As Range, check As Boolean
    Dim LastRow As Integer, icounter As Integer
    Dim Rng As Range, Rng2 As Range


    Set Rng = Target.End(xlToLeft)
    
    If IsDate(Target.Value) Then
        LastRow = Range(Target, Target.End(xlDown)).Cells.Count - 1
        icounter = 1
        Do Until icounter = LastRow Or check = True
            If Target.Offset(icounter, 0).Interior.Color <> vbYellow Then
                check = True
                Target.Offset(icounter, 0).Copy
            End If
            icounter = icounter + 1
        Loop
        Range(Target.Offset(1, 0), Target.End(xlDown)).PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
        Application.EnableEvents = False
        Target.Select
        Application.EnableEvents = True
        Exit Sub
    End If
    LastRow = Range(Rng, Rng.End(xlDown)).Cells.Count - 1
    If IsDate(Rng.Value) Then
        icounter = 1
        Do Until icounter = LastRow Or check = True
            If Rng.Offset(icounter, 0).Interior.Color <> vbYellow Then
                check = True
                Rng.Offset(icounter, 0).Copy
            End If
            icounter = icounter + 1
         Loop
        Range(Rng.Offset(1, 0), Rng.Offset(LastRow, 0)).PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
        Application.EnableEvents = False
        Target.Select
        Application.EnableEvents = True
        Set MatrixRng = Range(Rng, Rng.End(xlToRight))
         If Not Intersect(Target, MatrixRng) Is Nothing Then
            Set DataRange = Range(Target.Offset(1, 0), Target.Offset(LastRow, 0))
            For Each Rng2 In DataRange
                If Not IsEmpty(Rng2) Then
                    Rng2.Offset(0, -Rng2.Column + Rng.Column).Interior.Color = vbYellow
                End If
            Next Rng2
         End If
    End If
Application.ScreenUpdating = True
End Sub