Benachbarte Zellen einfärben

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_Change(ByVal Target As Range) Dim A On Error Resume Next With Target.Range("A1") A = Split(.Value, "h") If UBound(A) > 0 Then .Resize(A(0), 1).Interior.Color = .Cells.Interior.Color Else Target.Interior.Pattern = xlNone End If End With End Sub

Hallo Tom,
.. wenn Du wirklich immer nur einen Textwert stellvertretenden für alle h einschreiben willst. Viel einfacher wäre es, wenn Du für jede Stunde den gleichen Namen einschreiben würdest. (die doppelten Stundennamen lassen sich mit bed. Formatierung viel einfacher nicht darstellen, als das was Du als Zielstellung angegeben hast.
Mein Lösungsansatz dafür hab ich Dir nachstehend aufgezeigt. Dieser setzt momentan noch voraus dass die Stundenanzahl immer eine Ziffer als erstes Zeichen steht und ab der 4 Stelle die Stundenbezeichnung steht, für die "gefärbt" werden soll. Etwas sicherer wäre es jedoch mit SUCHEN() in dem entsprechenden Formelteil zu arbeiten. Darauf hab ich jetzt verzichtet, weil ich sowieso für die zuerst geschilderte Variante plädiere. Solltest Du Dich doch für die untenstehende Variante entscheiden, so wisse, dass durch kopieren einer Zele (gesamt, nicht nur des Zelldatenwertes) aus drei bedingten Formatierungsregeln, schnell ein vielfaches werden kann.

Arbeitsblatt mit dem Namen 'Tabelle1'
	A	B	C	D
1		Montag	Dienstag	Mittwoch
2	1. Stunde	4h NABU	3h Klima	2h BNE
3	2. Stunde
4	3. Stunde			2h Klima
5	4. Stunde		2h BNE
6	5. Stunde	2h BNE
7	6. Stunde			2h NABU
8	7. Stunde
9

Zelle	bedingte Formatierung...	Format
B2	1: (TEIL(VERWEIS(9;1/(B$1:B2>"");B$1:B2);4;99)="BNE")(LINKS(VERWEIS(9;1/(B$1:B2>"");B$1:B2);1)1&gt=ZEILE()+1-VERWEIS(9;1/(B$1:B2>"");ZEILE(B$1:B2)))	abc
B2	2: (TEIL(VERWEIS(9;1/(B$1:B2>"");B$1:B2);4;99)="Klima")(LINKS(VERWEIS(9;1/(B$1:B2>"");B$1:B2);1)1&gt=ZEILE()+1-VERWEIS(9;1/(B$1:B2>"");ZEILE(B$1:B2)))	abc
B2	3: (TEIL(VERWEIS(9;1/(B$1:B2>"");B$1:B2);4;99)="NABU")(LINKS(VERWEIS(9;1/(B$1:B2>"");B$1:B2);1)1&gt=ZEILE()+1-VERWEIS(9;1/(B$1:B2>"");ZEILE(B$1:B2)))	abc

Verwendete Systemkomponenten: [Windows (32-bit) NT 6.02] MS Excel 2010

Diese Tabelle wurde mit Tab2Html (v2.6.0) erstellt. ©Gerd alias Bamberg

Gruß Werner
.. , - ...

"die doppelten Stundennamen lassen sich mit bed. Formatierung viel einfacher nicht darstellen":
_ Es wird in den Zellen B2:B5 4 mal "4h NABU" geschrieben.
_ Hintergrundfarbe wird mit bed.For. "=Rechts(B2;4)="NABU" auf Blau gesetzt
_ Schriftfarbe wird mit "=UND(B2=B1";Rechts(B2;4)="NABU")" auf dieselben Blau gesetzt und damit ist der Text nicht sichtbar.
Für jeden Eintrag müssen 2 bed.For. angelegt werden. Dafür aber einfachere.
Nach dem Motto der faule Programmierer "mache nicht selber, was der Computer für dich machen kann": die Bedingte Formatierung per Makro setzen:


Sub FC_Setzen()
Dim P
Dim FC As FormatCondition
With Range("B2:F7")
.FormatConditions.Delete
For Each P In Array(Array("NABU", 15123099), Array("BNE", 49407), Array("Klima", 5296274), Array("xyz", 16777215))
Set FC = .FormatConditions.Add(Type:=xlExpression, Formula1:="=RECHTS(B2;" & Len(P(0)) & ")=""" & P(0) & """")
FC.Interior.Color = P(1)
FC.StopIfTrue = False
Set FC = .FormatConditions.Add(Type:=xlExpression, Formula1:="=UND(B1=B2;RECHTS(B2;" & Len(P(0)) & ")=""" & P(0) & """)")
FC.Font.Color = P(1)
FC.StopIfTrue = False
Next
End With
End Sub

Dann ist nur noch die Frage an dem "faulen" Programmierer: gibt es auch einen Trick, um die aktuelle Farbegebung, diese komischen Zahlen, zu lesen?
Na klar:


Sub Farbe_lesen()
Dim Z, D, s
Set D = CreateObject("Scripting.Dictionary")
On Error Resume Next
For Each Z In Worksheets(1).Range("B2:C7")
If Z.Value  "" Then D.Add Mid(Z.Value, InStrRev(Z.Value, " ") + 1), Z.Interior.Color
Next
For Each Z In D.Keys
s = s & ",Array(""" & Z & """, " & D(Z) & ")"
Next
Debug.Print "Array(" & Mid(s, 2) & ")"
End Sub

(funkioniert aber nur, wenn die Farbe tatsächlich gesetzt und nicht per bed.For. "nur angezeigt" werden)
VG
Yal

Sub AllePlane_herstellen() ' erstellt Stundenplan der pro Klasse Dim wZ As Worksheet 'Ziel-Worksheet Dim zQ As Range 'Quell-Zelle With Worksheets("Tabelle1") For Each zQ In .Range("C1:T1") Set wZ = WähleOderHerstelle(zQ.Value, "Vorlage") wZ.Range("B2:F30").ClearContents .Cells(2, zQ.Column).Resize(5, 1).Copy wZ.Range("B2") .Cells(8, zQ.Column).Resize(5, 1).Copy wZ.Range("C2") .Cells(14, zQ.Column).Resize(5, 1).Copy wZ.Range("D2") .Cells(20, zQ.Column).Resize(5, 1).Copy wZ.Range("E2") .Cells(26, zQ.Column).Resize(5, 1).Copy wZ.Range("F2") Next End With Application.CutCopyMode = False End Sub Private Function WähleOderHerstelle(Blattname, wsVorlage) As Worksheet Dim ws As Worksheet On Error Resume Next Set ws = ThisWorkbook.Worksheets(Blattname) If ws Is Nothing Then Set ws = ThisWorkbook.Worksheets(wsVorlage).Copy ws.Name = Blattname End If Set WähleOderHerstelle = ws End Function

Private Sub Worksheet_Change(ByVal Target As Range) Dim A Dim F On Error Resume Next Application.ScreenUpdating = False With Target.Range("A1") If Intersect(.Cells, Range("C2:T31")) Is Nothing Then Exit Sub Set F = Range("V:V").Find(.Value) If Not F Is Nothing Then A = Split(LCase(.Value), "h") If UBound(A) > 0 Then .Resize(A(0), 1).Interior.Color = F.Interior.Color Else Target.Select Do Selection.Interior.Pattern = xlNone Selection.Offset(1, 0).Select Loop While Selection = "" And ((Selection.Row - Target.Row)

Sub AllePlane_herstellen() ' erstellt Stundenplan der pro Klasse Dim wZ As Worksheet 'Ziel-Worksheet Dim zQ As Range 'Quell-Zelle With ActiveWorkbook.Worksheets("Tabelle1") For Each zQ In .Range("C1:T1") Set wZ = WähleOderHerstelle(zQ.Value, "Vorlage") wZ.Range("B2:F30").ClearContents .Cells(2, zQ.Column).Resize(5, 1).Copy wZ.Range("B2") .Cells(8, zQ.Column).Resize(5, 1).Copy wZ.Range("C2") .Cells(14, zQ.Column).Resize(5, 1).Copy wZ.Range("D2") .Cells(20, zQ.Column).Resize(5, 1).Copy wZ.Range("E2") .Cells(26, zQ.Column).Resize(5, 1).Copy wZ.Range("F2") Next End With Application.CutCopyMode = False End Sub Private Function WähleOderHerstelle(Blattname, wsVorlage) As Worksheet Dim ws As Worksheet On Error Resume Next With ActiveWorkbook Set ws = .Worksheets(Blattname) If ws Is Nothing Then Set ws = .Sheets(wsVorlage).Copy(After:=.Sheets(.Sheets.Count)) ws.Name = Blattname End If End With Set WähleOderHerstelle = ws End Function

Beliebteste Forumthreads (12 Monate)

21 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

21
Beiträge zum Forumthread

Beiträge zu diesem Forumthread