Re: Danke und Zusatzfrage
08.06.2003 20:48:59
L.Vira
Ich meinte damit, das auch noch auf das Calculate- Ereignis auszudehnen. Der Haken ist, dass wenn der Zellbereich sehr
groß ist, die Berechnung ggf., je nach Rechnerleistung , dauern kann. Kannst es ja mal probieren.''Erstellt von L.Vira zur freien Verwendung(ohne Garantie)
''--------------------------------------------------------------
''Theoretisch kann die ganze Spalte A genutzt werden, praktisch
''ist das aber sinnlos, weil interaktiv nur 40 Farben zur
''Verfügung stehen. Man kann eine Farbe aber auch mehrfach
''verwenden, wenn das gewünscht ist und Sinn macht.
''Das Makro: Farben_eintragen ausführen. Es wird ein Blatt
''mit dem Namen Farbgültigkeit erzeugt, falls es noch nicht
''vorhanden ist.
''In Spalte A, beginnend in A1, die Werte eintragen, die bei
''Eingabe in eine Tabelle eine bestimmte Farbe erhalten sollen.
''In der Spalte B die Füllfarbe der Zellen in der gewünschten
''Farbe formatieren. Beides muss lückenlos sein.
''Nochmals das Makro: Farben_eintragen ausführen.
''---------------------------------------------------------------
''In die Tabellenmodule, in denen das wirksam werden soll
''denn folgenden Code kopieren:
''---------------------------------------------------------------
'Option Explicit
'Private Sub Worksheet_Calculate()
'Dim Bereich As Range, C As Range, MSG As Integer
'If TypeName(Selection) <> "Range" Then Exit Sub
'Set Bereich = ActiveSheet.UsedRange
'If Bereich.Cells.Count > 1000 Then
' MSG = MsgBox("Der zu berechnende Bereich ist sehr groß!" & Chr(10) & _
' "Die Berechnung kann länger dauern, dennoch weiter? ", 32 + 4, "wills wissen...")
' If MSG = vbNo Then Exit Sub
'End If
'For Each C In Bereich
' On Error GoTo ENDE 'Blatt Farbgültigkeit nicht vorhanden
' C.Interior.ColorIndex = Col_Index(C.Value)
'Next
'ENDE:
'End Sub
'Private Sub Worksheet_Change(ByVal Target As Range)
'If Target.Count > 1 Then Exit Sub
'''Für die Füllfarbe
'Target.Interior.ColorIndex = Col_Index(Target.Value)
'''Für die Schriftfarbe
''Target.Font.ColorIndex = Col_Index(Target.Value)
'End Sub
''---------------------------------------------------------------
''Diesen Code in ein Standardmodul kopieren:
Option Explicit
Const FARBSHEET As String = "Farbgültigkeit"
Function Col_Index(Wert As Variant) As Byte
Dim F As Long, arrWert As Variant, T As Variant, lZ As Long
lZ = 65536
If Sheets(FARBSHEET).[a65536] = "" Then
lZ = Sheets(FARBSHEET).[a65536].End(xlUp).Row
End If
arrWert = Sheets(FARBSHEET).Range("A1:A" & lZ)
For Each T In arrWert
F = F + 1
'Wenn Groß- Kleinschreibung ignoriert werden soll:
' If UCase(T) = UCase(Wert) Then
' Col_Index = Sheets(FARBSHEET).Cells(F, 2)
' End If
'Wenn Groß- Kleinschreibung beachtet werden soll:
If T = Wert Then
Col_Index = Sheets(FARBSHEET).Cells(F, 2)
End If
Next
End Function
Sub Farben_eintragen()
Dim z As Long, lZ As Long, Wsh As Worksheet, bolFound As Boolean
''Testen, ob Blatt schon existiert
For Each Wsh In ActiveWorkbook.Worksheets
If UCase(Wsh.Name) = UCase(FARBSHEET) Then
bolFound = True
Exit For
End If
Next
''Wenn nicht, dann erzeugen
If Not bolFound Then
Set Wsh = Worksheets.Add(before:=Sheets(1))
Wsh.Name = FARBSHEET
Set Wsh = Nothing
End If
lZ = 65536
If Sheets(FARBSHEET).[a65536] = "" Then
lZ = Sheets(FARBSHEET).[a65536].End(xlUp).Row
End If
For z = 1 To lZ
Sheets(FARBSHEET).Cells(z, 2) = Sheets(FARBSHEET).Cells(z, 2).Interior.ColorIndex
Next
End Sub