Position und Länge von Stringeinfärbungen berechnen

[Nonexperta]

Hallo VBA Experten,

ich bräuchte mal Rat, oder besser gesagt etwas VBA Code. Ich habe in meiner Zelle
Strings stehen, die ab einer bestimmten Stelle rot eingefärbt sind. Ich brauche nun
VBA Code der mir ausgibt, ab welcher Stelle die Rotfärbung eintritt und ab wann diese
in der betreffenden Zelle wieder aufhört.

Danke im voraus!

[schauan]

Hallöchen,

probiere es mal damit. Eventuell musst Du den Zahlencode 255 anpassen, falls Du oder Dein Excel ein anderes rot hast als ich

Code:

Sub ColorPosition()
Dim iChar As Integer, strPos As String
With ActiveCell
  Do While iChar < Len(.Value)
    iChar = iChar + 1
    If .Characters(Start:=iChar, Length:=1).Font.Color = 255 Then
      If iChar > 1 And .Characters(Start:=iChar - 1, Length:=1).Font.Color <> 255 Then
        strPos = strPos & "S" & iChar & ","
      ElseIf iChar = 1 Then
        strPos = strPos & iChar & ","
      End If
    Else
      If iChar > 1 Then
        If .Characters(Start:=iChar - 1, Length:=1).Font.Color = 255 Then strPos = strPos & "E" & iChar & ","
      End If
    End If
  Loop
End With
End Sub

[SonjaFido]

Hallo André,

das Thema interessiert mich auch. Probiere mit:

Code:

Sub Testfärben()
ActiveCell.Characters(Start:=6, Length:=7).Font.Color = 255
End Sub

Deinen Code aus und es passiert nichts.


Sonja

[SonjaFido]

Hab mich mal selbst dran gesetzt:

Code:

Sub ColorPosition()
'Erzeugt eine Zeichenkette mit den Start- und Endpositionen einer Einfaerbung
'Variablendeklarationen
Dim iChar As Integer, strPos As String
'Mit der aktiven Zelle
With ActiveCell
  'Schleife solange Zaehler kleiner als Laenge der Zeichenkette ist
  Do While iChar < Len(.Value)
    'Zaehler hochsetzen
    iChar = iChar + 1
    'Wenn die Farbe des Zeichens 255 ist, dann
    If .Characters(Start:=iChar, Length:=1).Font.Color = 255 Then
      'Wenn es min. das 2. Zeichen ist und die Farbe das vorigen Zeichens nicht 255, dann
      If iChar > 1 And .Characters(Start:=iChar - 1, Length:=1).Font.Color <> 255 Then
        'Startposition uebernehmen
        strPos = strPos & "S" & iChar & ","
      'Oder wenn es das erste Zeichen ist, dann
      ElseIf iChar = 1 Then
        'Startposition uebernehmen
        strPos = strPos & iChar & ","
      'Ende Wenn es min. das 2. Zeichen ist und die Farbe das vorigen Zeichens nicht 255, dann
      End If
    'Oder Wenn die Farbe des Zeichens nicht 255 ist, dann
    Else
      'Wenn es nicht das erste Zeichen ist, dann
      If iChar > 1 Then
        'Wenn die Farbe des vorhergehenden Zeichens 255 ist, dann Endposition setzen
        If .Characters(Start:=iChar - 1, Length:=1).Font.Color = 255 Then strPos = strPos & "E" & iChar & ","
      End If
    'Ende Wenn die Farbe des Zeichens 255 ist, dann
    End If
  'Ende Schleife solange Zaehler kleiner als Laenge der Zeichenkette ist
  Loop
'Ende Mit der aktiven Zelle
End With
'Ausgabe der Start- und Endpositionen
MsgBox strPos
End Sub

Den code kann man sicherlich noch eleganter lösen.

[schauan]

Hallo Sonja,

ergänze bitte vor End Sub

MsgBox strPos

ich hab ganz verpasst, den code wie von mir gewohnt zu kommentieren und hole das gleich nach. In der Zeichenkette stehen die jeweiligen Anfangs- und Endpositionen, immer mit S und E gekennzeichnet. Könnten ja auch mehrere rote Teile sein

[SonjaFido]

Hallo André,

habe zu diesem Thema, mal diesen Code geschrieben:

Code:

Sub Position()
Dim i As Integer, a As Integer
Range("a1").Select

'Position:
For i = 1 To Len(ActiveCell.Value)
If ActiveCell.Characters(i, 1).Font.Color = 255 Then
    For a = i To Len(ActiveCell.Value)
    If Not ActiveCell.Characters(a, 1).Font.Color = 255 Then GoTo X
    Next a
End If
Next i
X:
Debug.Print "Position: " & i & " Länge = " & a - i

End Sub

Er funktioniert und ist schön kurz. Oder gibt es dazu irgendwelche Einwände?

[schauan]

Hallo Sonja,

ja, geht auch. Damit wird nur das erste Auftreten einer Färbung ermittelt - reicht bestimmt meistens.
Bei mir werden alle ausgegeben, und die Längen müssten noch berechnet werden.

[Nonexperta]

Hallo Sonja und André,

leider war ich ortsabwesend, deshalb kann ich mich erst jetzt bei
euch bedanken. Nachträglich aber nicht weniger herzlich
für eure Mühe und Einsatz.