Colour cell dependent on condition

[dek]

Attached : test_.xls

Hi,
Re: Colouring cell based on condition

Two sheets:
- Status : provides the condition for each person (holidays, etc)
- Snapshot : the report which requires updating via VBA or another means

Objective:
- The "snapshot" report in reality is quite long in the working version and takes considerable time to update each week manually. The sample provided has 5 activities.
- The "snapshot" report requires to be updated with the appropriate colours* from the "status" report.

* Happy for the colors to be changed in the solution.

Thanks in advance,
DE

[dek]

Alternative method is to apply the colour from each person (see "Alternative" in "Status" sheet) as a painter method in the Snapshot sheet.

Unsure of VBA code to execute this.
Any assistance would be appreciated.

[Bob Phillips]

[vba]

Sub UpdateSnapshot()
Dim LastRow As Long
Dim LastCol As Long
Dim RowNum As Long
Dim sh As Worksheet
Dim i As Long, j As Long

Application.ScreenUpdating = False

Set sh = Worksheets("Status")
With Worksheets("Snapshot")

LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = 5 To LastRow

LastCol = .Cells(i, .Columns.Count).End(xlToLeft).Column
For j = 3 To LastCol

On Error Resume Next
RowNum = Application.Match(.Cells(i, j), sh.Columns(3), 0)
On Error GoTo 0
If RowNum > 0 Then

If sh.Cells(RowNum, "D").Value <> "" Then

.Cells(i, j).Interior.ColorIndex = sh.Cells(3, "D").Interior.ColorIndex
ElseIf sh.Cells(RowNum, "E").Value <> "" Then

.Cells(i, j).Interior.ColorIndex = sh.Cells(3, "E").Interior.ColorIndex
ElseIf sh.Cells(RowNum, "F").Value <> "" Then

.Cells(i, j).Interior.ColorIndex = sh.Cells(3, "F").Interior.ColorIndex
ElseIf sh.Cells(RowNum, "G").Value <> "" Then

.Cells(i, j).Interior.ColorIndex = sh.Cells(3, "G").Interior.ColorIndex
Else

.Cells(i, j).Interior.ColorIndex = xlColorIndexNone
End If
End If
Next j
Next i
End With

Application.ScreenUpdating = True
End Sub
[/vba]

[dek]

XLD,

Many thanks for the reply. I have tested the code on my live document.
I have only 1 issue to resolve as the code currently highlights the row outside my data range.

Question: Can you please provide a solution for limiting the range of the "Snapshot" sheet to 6 columns.

Currently the code performs a count of the columns.

I'm unsure how to modify the code to fix to 6 columns.

DE

[Bob Phillips]

I thought you said the real data was much greater.

Anyway, change

[vba]
For i = 5 To LastRow[/vba]

to

[vba]
For i = 5 To 10[/vba]

[dek]

XLD,

Apologies. The data is much greater, however, in the row range (up to 2000 cells). The column range is fixed.

Many thanks again

DE

[dek]

xld,

Your adjustment pertains to the row range rather than the column range as requested.

Still struggling to fix the column range from column C to column H

David

[Bob Phillips]

[vba]

Sub UpdateSnapshot()
Dim LastRow As Long
Dim LastCol As Long
Dim RowNum As Long
Dim sh As Worksheet
Dim i As Long, j As Long

Application.ScreenUpdating = False

Set sh = Worksheets("Status")
With Worksheets("Snapshot")

LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = 5 To LastRow

LastCol = .Cells(i, .Columns.Count).End(xlToLeft).Column
If LastCol > 8 Then LastCol = 8
For j = 3 To LastCol

On Error Resume Next
RowNum = Application.Match(.Cells(i, j), sh.Columns(3), 0)
On Error GoTo 0
If RowNum > 0 Then

If sh.Cells(RowNum, "D").Value <> "" Then

.Cells(i, j).Interior.ColorIndex = sh.Cells(3, "D").Interior.ColorIndex
ElseIf sh.Cells(RowNum, "E").Value <> "" Then

.Cells(i, j).Interior.ColorIndex = sh.Cells(3, "E").Interior.ColorIndex
ElseIf sh.Cells(RowNum, "F").Value <> "" Then

.Cells(i, j).Interior.ColorIndex = sh.Cells(3, "F").Interior.ColorIndex
ElseIf sh.Cells(RowNum, "G").Value <> "" Then

.Cells(i, j).Interior.ColorIndex = sh.Cells(3, "G").Interior.ColorIndex
Else

.Cells(i, j).Interior.ColorIndex = xlColorIndexNone
End If
End If
Next j
Next i
End With

Application.ScreenUpdating = True
End Sub
[/vba]