Excel VBA Formatting cells by Date Range

[koala]

Conditional formatting for a date range

--------------------------------------------------------------------------------

Is someone able to assist.

I have a spreadsheet that lists the staff and which task they are t
perform on a given day. (Spreadsheet Name is Allocations)

Column A has the dates for a whole year starting at row 5

Row 4, Columns B to AD list the Staff Names

Row 5 onwards for Column B to AD lists the tasks. This way I can find
date in Column A, look across that row for a task, and see who is t
perform it.

Example:

Date Staff A Staff B Staff C
1/1/04 Zaa Zxy Zbg
2/1/04 Zxy Zbg Zaa
3/1/04 Zbg Zaa Zxy
4/1/04 Zaa Zxy Zbg
5/1/04 Zxy Zbg Zaa



The leave details are on another worksheet in 3 columns. (Spreadshee
Name is Leave)

These columns are:

A. Name
B. Start Date
C. Finish Date

Example:

Name StartDate Finish Date
StaffA 1/1/04 2/1/04
StaffB 3/1/04 5/1/04
StaffC 2/1/04 4/1/04
StaffA 4/1/04 5/1/04

I need some code to colour the cells for a staff members allocation
when they are on leave.

Colour used is "VIOLET"

As can be seen by STAFFA, above, sometimes staff have 2 or more leav
periods in a year. eg 2 weeks in March, 2 weeks in October

The code therefore needs to:

1. Look at staff Name on Leave Sheet.
2. Find corresponding Name in Row 4 on Allocation Sheet.
3. Look at Start Date and Finish Date on Leave Sheet.
4. Colour that range for that staff member on Allocation Sheet.

With the above example the following cells marked X would be shade
Violet.

Date Staff A Staff B Staff C
1/1/04 X - -
2/1/04 X - X
3/1/04 - X X
4/1/04 X X X
5/1/04 X X -


Variables:
Sometimes there are more or less Staff Members.

Staff may have 2 or more leave periods.


I have already used the three Conditional Formatting options t
highlight various tasks, so need code to shade the cells

I have very limited knowledge of macros and code, and dont know if thi
is possible.

Could someone please assist.

cheers
Koal

 

[Bob Phillips]

Hi Koala,

Here is some code. Note that is event code so it will set the colour as you
enter the tasks. To update what you already have you need to edit each cell
(just select the cell, F2, Enter).

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cRows As Long
Dim i As Long
Dim shLeave As Worksheet
Dim Matched As Boolean

On Error GoTo ws_exit:
Application.EnableEvents = False
With Target
If .Row > 4 Then
Set shLeave = Worksheets("Leave")
cRows = shLeave.Cells(Rows.Count, "A").End(xlUp).Row
Matched = False

For i = 2 To cRows
If shLeave.Cells(i, "A").Value = .Parent.Cells(4,
..Column).Value Then
If shLeave.Cells(i, "B").Value <= .Parent.Cells(.Row,
1).Value Then
If shLeave.Cells(i, "C").Value >=
..Parent.Cells(.Row, 1).Value Then
Matched = True
Exit For
End If
End If
End If
Next i

If Matched Then
.Interior.ColorIndex = 13
End If

End If

End With

ws_exit:
Application.EnableEvents = True
End Sub

'This is worksheet event code, which means that it needs to be
'placed in the appropriate worksheet code module, not a standard
'code module. To do this, right-click on the sheet tab, select
'the View Code option from the menu, and paste the code in.



--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[koala]

Hi Bob,

Thank you very much for your reply.

It works pretty much how I needed it.

If it could colour the cells as the leave dates were entered on th
leave sheet it would be perfect, as the Allocations sheet is alread
populated with data, and it means I have to F2 each cells. (there are
lot - 365 rows x approx 30 columns).

I am not sure if this is possible, so would be grateful if you coul
advise a fix for this.

much appreciated

cheers
Koala :

 

[Bob Phillips]

Bedtime now,. will do it for you tomorrow.

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[koala]

Thanks Bob,

I look forward to you assistance.

cheer

 

[koala]

Hi everyone,

If soemone could assist with this I would be most grateful.

Bobs reply works fine, I just need to make it automatic, for instance,
each time the worksheet is recalculated or immediatley I enter a ne
leave date on the leave sheet.

Hoping someone can assist.

cheers
Koal

 

[koala]

Bob,

I dont know if you have had time to look at the fix for me yet, howeve
I hope you do get a chance and are able to help as I realy want t
complete this task.

Thanks in advance
Koal

 

[Bob Phillips]

Koala,

Looked at it today, but I get an error on a line of code I use every day.
Will keep on.

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[Bob Phillips]

Koala,

Sorry to take so long. I had to develop it on another machine as I got this
crazy problem on my laptop. Anyway here it is.

Couple of points.

I have assumed two worksheets named Work and Leave, change to suit.
The original code I gave is part of this solution, so keep that.
I have provided 2 things, one is a change event for the Leave worksheet that
will update any related work tasks if an end date is entered, changed. The
other is a little routine that will convert all of your existing entries
(just run the macro 'Initialise' for this.

The code. The first bit goes in a standard code module.


Sub UpdateTasks(Name As String, _
StartDate As Date, _
EndDate As Date, _
Colour As Long)
Dim i As Long
Dim j As Long

With Worksheets("Work")
For i = 5 To .Cells(Rows.Count, "A").End(xlUp).Row
For j = 2 To 30 'column AD
If Name = .Cells(4, j).Value And _
StartDate <= .Cells(i, 1).Value And _
EndDate >= .Cells(i, 1).Value Then
.Cells(i, j).Interior.ColorIndex = Colour
End If
Next j
Next i
End With

End Sub

Sub Initialise()
Dim i As Long
Dim cRows As Long

Worksheets("Work").Range("B5:AD1000").Interior.ColorIndex = -4142
With Worksheets("Leave")
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
If .Cells(i, 2).Value <> "" And _
.Cells(i, 3).Value <> "" Then
UpdateTasks .Cells(i, 1).Value, .Cells(i, 2).Value, _
.Cells(i, 3).Value, 13
End If
Next i
End With

End Sub


Then add this to the Leave worksheet code module


Private Sub Worksheet_Change(ByVal Target As Range)
Dim cRows As Long
Dim i As Long
Dim shLeave As Worksheet
Dim Matched As Boolean

On Error GoTo ws_exit:
Application.EnableEvents = False
With Target
If .Column = 3 Then
If .Offset(0, -1).Value <> "" Then
UpdateTasks .Offset(0, -2).Value, .Offset(0, -1).Value,
..Value, 13
End If
End If
End With

ws_exit:
Application.EnableEvents = True
End Sub

'This is worksheet event code, which means that it needs to be
'placed in the appropriate worksheet code module, not a standard
'code module. To do this, right-click on the sheet tab, select
'the View Code option from the menu, and paste the code in.

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[koala]

Bob

Thank you so much..

The code works out exactly as I wished.

It is a big relief and timesaver to me now.

cheers
Koala
;

 

[Bob Phillips]

Pleasure, sorry about the delay.

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)