AW: Bedingte Formatierung übertragen (andere Tabel
20.04.2008 09:23:34
fcs
Hallo Robert,
bedingte Formatierungen sind nun mal sehr rechenintensiv. Insbesondere wenn sie so komplex aufgebaut sind wie in deinem Fall.
gg. während der Eingaben im Tabellenblatt Tabelle2 unter Optionen das automatische Berechnen auf manuell umstellen.
Alternative: Farbformatierung der Zeilen in Tabelle1 per Makro. Das geht ohne Hilfsspalten. Das Makro wird immer dann ausgeführt, wenn Tabelle1 selektiert wird. Das folgende Makro im VBA-Editor unter Tabelle1 einfügen.
Gruß
Franz
Option Explicit
Private Const lngFarbeHeute = 36 'hellgelb
Private Const lngFarbeBald = 40 'gelbbraun
Private Sub Worksheet_Activate()
Dim objWksDatum As Worksheet 'Tabellenblatt mit bedingter Formatierung auf Basis Datum
Dim objWksMe As Worksheet 'Tabellenblatt in dem Namen ggf. formatiert werden sollen
Dim objZelle As Range
Dim strAdresse1 As String
Dim lngZeileMe As Long
Dim strName As String, strVorname As String
Dim bolVorname As Boolean
Set objWksDatum = Worksheets("Tabelle2")
Set objWksMe = Me
With objWksMe
'Formatierung Zellfarbe zurücksetzen
.Range(.Columns(1), .Columns(4)).Interior.ColorIndex = xlColorIndexNone
'Zeilen in Tabelle1 abarbeiten
Application.ScreenUpdating = False
For lngZeileMe = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
strName = .Cells(lngZeileMe, 3).Value
strVorname = .Cells(lngZeileMe, 4).Value
bolVorname = False
With objWksDatum
'Name in Spalte A von Tabelle 2 suchen
Set objZelle = .Columns.Find(what:=strName, LookIn:=xlValues, lookat:=xlWhole)
If objZelle Is Nothing Then
MsgBox "Name """ & strName & """ in Tabelle " & .Name & " nicht gefunden!"
Else
strAdresse1 = objZelle.Address
Do
'Prüfung des Vornamens
If objZelle.Offset(0, 1).Value = strVorname Then
bolVorname = True
'Zeitraum überprüfen
'UND(C2-HEUTE()>0;C2-HEUTE() 0 _
And (.Cells(objZelle.Row, 3) - Date) =0;D2-HEUTE()>=0)
ElseIf (Date - .Cells(objZelle.Row, 3)) >= 0 _
And (.Cells(objZelle.Row, 4) - Date) >= 0 Then
With objWksMe
.Range(.Cells(lngZeileMe, 1), .Cells(lngZeileMe, 4)).Interior.ColorIndex _
= lngFarbeBald
Exit Do
End With
End If
End If
'nächsten Eintrag des Namens suchen
Set objZelle = .Columns(1).FindNext(After:=objZelle)
Loop Until objZelle.Address = strAdresse1
If bolVorname = False Then
MsgBox "Name """ & strName & ", " & strVorname & """ in Tabelle " _
& .Name & " nicht gefunden!"
End If
End If
End With
Next
Application.ScreenUpdating = True
End With
Set objWksDatum = Nothing
Set objWksMe = Nothing
Set objZelle = Nothing
End Sub