Erwischt! ;-]
30.07.2020 18:47:58
Luc:?
Hallo, Case (& Akatosh);
Deine Pgmm setzen voraus, dass die AbwVJ stets positiv und die AbwPlan stets negativ ist. Dementsprd hast Du auch die TestDatenErweiterung gestaltet - ein nicht realitätskonformer Fehler!
Dagg stelle ich dann doch mal meinen weniger aufwendigen Entwurf.
Voraussetzungen:
• Sinnvollere Fmln in D:E nebst Formatierung als %-Zahl mit einer Dezimale:
D3ff:=RUNDEN(B3/A3-1;3)
E3ff:=RUNDEN(B3/C3-1;3)
• 3 benannte Fmln, deren definierte Namen in der bzw als HauptFml verwendet wdn:
AbwVJuPl:=$D$2&": "&AbwTextVJ&ZEICHEN(10)&$E$2&": "&AbwTextPl
AbwTextVJ:=ZELLE.ZUORDNEN(53;$D3)
AbwTextPl:=ZELLE.ZUORDNEN(53;$E3)
Die erstgenannte HptFml übernimmt den KopfText der Spalte D:E.
• AusgabeBereich in F muss hier noch manuell auf Zeilenumbruch gestellt wdn.
Bedienung:
Bei Bedarf kann eine EinzelZelle durch Klicken in dieselbe auf Fml(-Name) umgestellt wdn und mit einem weiteren Klick wieder auf formatierten Text. Auf LeerZellen und Löschungen wird nicht reagiert, damit diese ermöglicht wdn. Zum Auslösen der Routine muss in eine leere Zelle also erst immer irgendetwas (keine fremde Fml!) eingetragen wdn. Es können auch mehrere oder alle Zellen auf 1× behandelt wdn, indem ihr Bereich kopiert und an gleicher Stelle 2× als Fml (fx) eingefügt wird.
Steuernde Ereignis- und ausführende Prozedur:
Beide im Dokument-KlassenModul des jeweiligen Blattes unterzubringen.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const adRelBer$ = "Tabelle1!F3:F30"
Dim zBer As Range
Set zBer = Me.Range(adRelBer)
If Not Intersect(Target, zBer) Is Nothing Then _
Call AbwTxFarben(Target, zBer)
Set zBer = Nothing
End Sub
Private Sub AbwTxFarben(Ziel As Range, zBer As Range)
Const fmAbw$ = "=AbwVJuPl"
Dim ix As Integer, anfAbw(2) As Long, lenAbw(1) As Long, _
fFrb(1) As Long, vsQBer(2) As Long, qz As Range, zz As Range
vsQBer(0) = -2: vsQBer(1) = -1: vsQBer(2) = -1
fFrb(0) = vbGreen: fFrb(1) = vbRed
anfAbw(0) = Len(zBer.Cells(1).Offset(vsQBer(2), vsQBer(0)).Text) + 3
anfAbw(2) = Len(zBer.Cells(1).Offset(vsQBer(2), vsQBer(1)).Text) + 3
Application.EnableEvents = False
For Each zz In Ziel
If zz.HasFormula Then
If zz.Formula = fmAbw Then
zz = zz.Value
For ix = 0 To 1
Set qz = zz.Offset(, vsQBer(ix))
If CBool(qz) Then
If CBool(ix) Then _
anfAbw(ix) = anfAbw(0) + lenAbw(ix - 1) + anfAbw(2)
lenAbw(ix) = Len(qz.Text)
zz.Characters(anfAbw(ix), _
lenAbw(ix)).Font.Color = fFrb(Abs(qz
So etwas hatte ich schon mal vor Jahren geschrieben, als spezielle UDF mit den entsprd FormatAngaben in den Argumenten und unterstützenden, physisch per Ereignis entkoppelten SubProzeduren. Aber so komplex und universell wollte ich hier nicht wdn… ;-)
Gruß, Luc :-?
Die universelle Befähigung zur Unfähigkeit macht jede menschliche Leistung zu einem unglaublichen Wunder. Stapps ironisches Paradoxon
Nichtsdestotrotz Durchblick verbessern mit