Moin!
Zunächst mal ist der Thread ja als gelöst markiert.
Desweiteren ist der Code in der Datei unstrukturiert und nicht mal eben so zu überarbeiten.
Da das Problem auch sehr speziell ist, bringt es der Gemeinschaft des Forums sicherlich wenig, wenn hier ein Code eingestellt wird, mit dem ein Außenstehender nix anfangen kann.
Falls sich die TE jedoch noch einmal meldet, bin ich gerne bereit, Zeit zu investieren.
Ansonsten sicherlich nicht.
Gruß Ralf
Warum bietet ihr keine Lösung ?
Hi,
ich habe jetzt mal den Code aus "DieseArbeitsmappe" entfernt, sowie den in Modul1 strukturiert und verkürzt und die Variablen sprechend gemacht:
Code:
Sub test()
Application.ScreenUpdating = False
Dim loSpUe As Long 'Spalte Übersicht
Dim i As Long 'Zeile Übersicht
Dim j As Long 'Spalte
Dim loZeMatrix As Long 'Zeile Kompetenz Matrix
With Worksheets("Übersicht")
.Range("O:FT").Interior.ColorIndex = xlNone
For loSpUe = 15 To .Cells.SpecialCells(xlCellTypeLastCell).Column 'Von Spalte O bis zur letzten beschriebenen
loZeMatrix = loSpUe - 11
For i = 4 To .Cells(Rows.Count, 4).End(xlUp).Row 'Von Zeile 4 bis zur letzten befüllten
If .Cells(3, loSpUe) <> 0 Then
'Kriterium 1
If UCase(.Range("F" & i)) = "X" Then
.Cells(i, loSpUe).Interior.ColorIndex = 5
End If
For j = 6 To 14
'Kriterium 2 - 9
If UCase(.Cells(i, j + 1)) = "X" Then
If UCase(Worksheets("Matrix").Cells(loZeMatrix, j)) = "X" Then
.Cells(i, loSpUe).Interior.ColorIndex = 5
End If
End If
Next j
'rote Farbe
If .Cells(i, loSpUe).Interior.ColorIndex = 5 Then
If .Range("A1").Value - .Range("D" & i).Value > 365 Or .Cells(i, loSpUe) = "" _
Or .Cells(i, loSpUe).Value < .Range("D" & i).Value Then
.Cells(i, loSpUe).Interior.ColorIndex = 3
End If
End If
'grüne Farbe
If .Cells(i, loSpUe).Interior.ColorIndex <> xlNone And .Cells(i, loSpUe).Value - .Range("D" & i).Value > 1 And .Range("A1").Value - .Range("D" & i).Value < 365 _
Or .Cells(i, loSpUe).Interior.ColorIndex <> xlNone And .Cells(i, loSpUe).Value - .Range("D" & i).Value = 1 And .Range("A1").Value - .Range("D" & i).Value < 365 _
Then
.Cells(i, loSpUe).Interior.ColorIndex = 4
End If
Else
.Cells(i, loSpUe).Interior.ColorIndex = xlNone
End If
Next i
Next loSpUe
End With
Application.ScreenUpdating = True
End Sub
Vielleicht kann auf dieser Basis weitergearbeitet werden.