AW: VBA Lösung gesucht - Danke Erich
24.08.2011 11:51:00
Tino
Hallo,
hier mal eine Variante, evtl. müsstest Du die Bereiche und die Tabelle anpassen
wenn es nicht wie im Beispiel aufgebaut ist.
Sub Test()
Dim ArrayData, n&, nn&, nnn&, nMaxColor&, lngColor&
Dim rng As Range
Dim iCalc%
Const lngRot& = 255
Const lngOrange& = 49407
With Tabelle1 'tabelle anpassen
ArrayData = .Range("A15", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 6)
Set rng = .Range("A3", .Cells(3, 1).End(xlDown)).Resize(, 2)
End With
With Application
iCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
With .WorksheetFunction
nMaxColor = .Max(lngRot, lngOrange) + 1
For n = 1 To rng.Rows.Count
lngColor = nMaxColor
For nn = 1 To Ubound(ArrayData)
If ArrayData(nn, 1) = rng(n, 1).Value Then
For nnn = 2 To Ubound(ArrayData, 2)
Select Case ArrayData(nn, nnn)
Case Is < 0
lngColor = lngRot 'rot
Exit For
Case 0 To 75
lngColor = .Min(lngColor, lngOrange) 'orange
End Select
Next nnn
Exit For
End If
Next nn
If lngColor = nMaxColor Then lngColor = xlColorIndexNone
rng(n, 2).Interior.Color = lngColor
Next n
End With
.Calculation = iCalc
.ScreenUpdating = False
.EnableEvents = False
End With
End Sub
Gruß Tino