AW: Zellen bedingt farblich hinterlegen
05.06.2009 19:59:26
Josef
Hallo Patrick,
der angepasste Code für deine gewünschten Spalten, je nachdem welcjh Version du willst.
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
'Beispiel ohne Farbtabelle
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sngValues(1 To 9) As Single
Dim lngColors(1 To 9, 1 To 9) As Long
Dim varRes As Variant
sngValues(1) = 1
sngValues(2) = 1.5
sngValues(3) = 2
sngValues(4) = 2.5
sngValues(5) = 3
sngValues(6) = 3.5
sngValues(7) = 4
sngValues(8) = 4.5
sngValues(9) = 5
lngColors(1, 1) = 50
lngColors(1, 2) = 50
lngColors(1, 3) = 50
lngColors(1, 4) = 6
lngColors(1, 5) = 6
lngColors(1, 6) = 44
lngColors(1, 7) = 44
lngColors(1, 8) = 3
lngColors(1, 9) = 3
lngColors(2, 1) = 50
lngColors(2, 2) = 50
lngColors(2, 3) = 6
lngColors(2, 4) = 6
lngColors(2, 5) = 6
lngColors(2, 6) = 44
lngColors(2, 7) = 44
lngColors(2, 8) = 3
lngColors(2, 9) = 3
lngColors(3, 1) = 50
lngColors(3, 2) = 6
lngColors(3, 3) = 6
lngColors(3, 4) = 6
lngColors(3, 5) = 44
lngColors(3, 6) = 44
lngColors(3, 7) = 44
lngColors(3, 8) = 3
lngColors(3, 9) = 3
lngColors(4, 1) = 6
lngColors(4, 2) = 6
lngColors(4, 3) = 6
lngColors(4, 4) = 44
lngColors(4, 5) = 44
lngColors(4, 6) = 44
lngColors(4, 7) = 44
lngColors(4, 8) = 3
lngColors(4, 9) = 3
lngColors(5, 1) = 6
lngColors(5, 2) = 6
lngColors(5, 3) = 44
lngColors(5, 4) = 44
lngColors(5, 5) = 44
lngColors(5, 6) = 44
lngColors(5, 7) = 44
lngColors(5, 8) = 3
lngColors(5, 9) = 3
lngColors(6, 1) = 44
lngColors(6, 2) = 44
lngColors(6, 3) = 44
lngColors(6, 4) = 44
lngColors(6, 5) = 44
lngColors(6, 6) = 44
lngColors(6, 7) = 3
lngColors(6, 8) = 3
lngColors(6, 9) = 3
lngColors(7, 1) = 44
lngColors(7, 2) = 44
lngColors(7, 3) = 44
lngColors(7, 4) = 44
lngColors(7, 5) = 44
lngColors(7, 6) = 3
lngColors(7, 7) = 3
lngColors(7, 8) = 3
lngColors(7, 9) = 13
lngColors(8, 1) = 3
lngColors(8, 2) = 3
lngColors(8, 3) = 3
lngColors(8, 4) = 3
lngColors(8, 5) = 3
lngColors(8, 6) = 3
lngColors(8, 7) = 3
lngColors(8, 8) = 13
lngColors(8, 9) = 13
lngColors(9, 1) = 3
lngColors(9, 2) = 3
lngColors(9, 3) = 3
lngColors(9, 4) = 3
lngColors(9, 5) = 3
lngColors(9, 6) = 3
lngColors(9, 7) = 13
lngColors(9, 8) = 13
lngColors(9, 9) = 13
With Target
If .Column = 4 Or .Column = 5 Then
If .Count = 1 Then
varRes = Application.Index(lngColors, Application.Match(Cells(.Row, 4), sngValues, 0), Application.Match(Cells(.Row, 5), sngValues, 0))
If IsNumeric(varRes) Then
Cells(.Row, 6).Interior.ColorIndex = varRes
Else
Cells(.Row, 6).Interior.ColorIndex = xlNone
End If
End If
End If
End With
End Sub
' **********************************************************************
' Modul: Tabelle2 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
'Beispiel mit Farbtabelle in der Tabelle
Private Const cstrRangeColors As String = "M3:U11" 'Bereich mit den Farben
Private Const cstrRangeValues As String = "M2:U2" 'Bereich mit den zu Vergleichenden Werten
Private Sub Worksheet_Change(ByVal Target As Range)
Dim varRes As Variant
Dim lngRow As Long, lngCol As Long
With Target
If .Column = 4 Or .Column = 5 Then
If .Count = 1 Then
varRes = Application.Match(Cells(.Row, 4), Range(cstrRangeValues), 0)
If IsNumeric(varRes) Then lngRow = varRes
varRes = Application.Match(Cells(.Row, 5), Range(cstrRangeValues), 0)
If IsNumeric(varRes) Then lngCol = varRes
If lngRow > 0 And lngCol > 0 Then
Cells(.Row, 6).Interior.ColorIndex = Range(cstrRangeColors).Cells(lngRow, lngCol).Interior.ColorIndex
Else
Cells(.Row, 6).Interior.ColorIndex = xlNone
End If
End If
End If
End With
End Sub
Gruß Sepp