Verbesserung auf FlipFlop-Änderung
28.01.2015 09:11:42
Luc:-?
Rem BspEventProz zum Ändern v.TextTeilen unter Berücksichtigung
' von SchriftMehrFarbigkeit m.RückgängigEffekt b.Wiederholung
' Vs1.1 -LSr\CyWorXxl -cd:20150128 -1pub:do.herber -lupd:do.t
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const adRelBer$ = "C:C", txQZTeil$ = "estado¦ido"
Dim idx(1) As Integer, ld As Long, p As Long, q As Long, z As Long, _
axQZ$(), clr, lt As Variant, t As Range, wf As WorksheetFunction
On Abs(Intersect(Target, Me.Range(adRelBer)) Is Nothing) GoTo fx
On Error GoTo fx: Set wf = WorksheetFunction
axQZ = Split(txQZTeil, "¦"): lt = Array(Len(axQZ(0)), Len(axQZ(1)))
For Each t In Target.Cells
If Not IsEmpty(t) Then
q = InStr(t, axQZ(0))
If CBool(q) Then
idx(0) = 0: idx(1) = 1
Else: q = InStr(t, axQZ(1))
If CBool(q) Then idx(0) = 1: idx(1) = 0
End If
End If
On Abs(q = 0) GoTo nx
If IsNull(t.Font.Color) Then
p = 1: z = 1: ld = lt(idx(1)) - lt(idx(0))
ReDim clr(1 To Len(t) + ld)
If CBool(ld) Then
For p = p To Len(t) + 1
If CBool(ld) And p = q + wf.Min(lt) Then
If ld > 0 Then
For z = p To p + ld - 1
clr(z) = clr(z - 1)
Next z
Else: p = p - ld
End If
End If
If z > UBound(clr) Then Exit For
clr(z) = t.Characters(p, 1).Font.Color: z = z + 1
Next p
Else: clr(p) = t.Characters(p, 1).Font.Color: p = p + 1
End If
t = Replace(t.Text, axQZ(idx(0)), axQZ(idx(1)))
For p = 1 To Len(t)
t.Characters(p, 1).Font.Color = clr(p)
Next p
Else: t = Replace(t.Text, axQZ(idx(0)), axQZ(idx(1)))
End If
nx: Next t
fx: If CBool(Err.Number) Then MsgBox "Fehler-Abbruch:" & vbLf & _
Err.Description, vbCritical, "Fehler " & CStr(Err.Number): Set t = Nothing
Set wf = Nothing
End Sub
Luc :-?