Bereich Färben wenn...

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

…VBA-Unterstützung, Leute;
1. Name definieren für das betroffene Blatt, zB letztEintrag bezogen auf ="".
2. BedingtFormat/6.MenüPkt: Bedingg1→ =letztEintrag="X" →Rot; Bedingg2→ =letztEintrag="Y" →Blau
3. Ereignisprozedur Worksheet_Change wie üblich anlegen → PgmKörper:

    Const lEintrN$ = "letztEintrag", relBerN$ = "A1:D4", sigSymb$ = "XY"
Static adVorgg$
Dim VorgPos As Long, VorgAdr As Variant
If Not Intersect(Target, Me.Range(relBerN)) Is Nothing Then
If Target.Count = 1 Then
If Not IsEmpty(Target) Then
If CBool(InStr(sigSymb, Target)) Then _
adVorgg = LTrim(adVorgg & " " & Target.Address)
ElseIf adVorgg  "" Then
VorgAdr = Split(adVorgg)
VorgPos = WorksheetFunction.Match(Target.Address, VorgAdr, 0) - 1
If VorgPos > -1 Then VorgAdr(VorgPos) = ""
adVorgg = Trim(Join(VorgAdr))
End If
VorgAdr = Split(adVorgg): Me.Names(lEintrN).Value = "=" & VorgAdr(UBound(VorgAdr))
ElseIf IsEmpty(Target.Cells(1)) Then
adVorgg = ""
End If
End If

Mit Auswahl mehrerer Zellen, deren 1. nicht leer ist, und Löschen aller wird die PgmVariable adVorgg geleert, ansonsten bleibt sie zwischen den AutoAufrufen erhalten.
Gruß Luc :-?

Private Sub Worksheet_Change(ByVal Target As Range) Const lEintrN$ = "letztEintrag", relBerN$ = "A1:D4", sigSymb$ = "XY" Static adVorgg$ Dim isLeerAdV As Boolean, VorgPos As Long, ZielAdr$, VorgAdr As Variant On Error GoTo fx If Not Intersect(Target, Me.Range(relBerN)) Is Nothing Then If Target.Count = 1 Then ZielAdr = Target.Address: Let isLeerAdV = adVorgg = "" If Not isLeerAdV Then VorgAdr = Split(adVorgg) On Error Resume Next VorgPos = WorksheetFunction.Match(ZielAdr, VorgAdr, 0) On Error GoTo fx If CBool(VorgPos) Then _ VorgAdr(VorgPos - 1) = "": adVorgg = Trim(Join(VorgAdr)) End If If Not IsEmpty(Target) Then If CBool(InStr(sigSymb, Target)) Then _ adVorgg = adVorgg & IIf(isLeerAdV, "", " ") & ZielAdr End If VorgAdr = Split(adVorgg) Me.Names(lEintrN).Value = "=" & VorgAdr(UBound(VorgAdr)) ElseIf IsEmpty(Target.Cells(1)) Then adVorgg = "" End If End If Exit Sub fx: MsgBox Err.Description, vbCritical, "InternFehler " & Err.Number End Sub

Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("A1:D4")) Is Nothing Then Select Case Target Case "X": Cells(1, 3).Interior.Color = RGB(255, 0, 0) Case "Y": Cells(1, 3).Interior.Color = RGB(0, 0, 255) Case "" Select Case True Case WorksheetFunction.CountIf(Range("A1:D4"), "X") = 0 And _ WorksheetFunction.CountIf(Range("A1:D4"), "Y") = 0 Cells(1, 3).Interior.Color = xlNone Case WorksheetFunction.CountIf(Range("A1:D4"), "X") > 0 And _ WorksheetFunction.CountIf(Range("A1:D4"), "Y") = 0 Cells(1, 3).Interior.Color = RGB(255, 0, 0) Case WorksheetFunction.CountIf(Range("A1:D4"), "X") = 0 And _ WorksheetFunction.CountIf(Range("A1:D4"), "Y") > 0 Cells(1, 3).Interior.Color = RGB(0, 0, 255) End Select End Select End If End Sub

Beliebteste Forumthreads (12 Monate)

Zelle	bedingte Formatierung...	Format
C1	1: =ZÄHLENWENN($A$1:$D$4;"X")	abc
C1	2: =ZÄHLENWENN($A$1:$D$4;"Y")	abc

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread