Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

Position und Länge von Stringeinfärbungen berechnen
#1
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!
Antworten Top
#2
Hallöchen,

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

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
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
Antworten Top
#3
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
Antworten Top
#4
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.
Antworten Top
#5
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 Smile
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
Antworten Top
#6
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?
[-] Folgende(r) 1 Nutzer sagt Danke an SonjaFido für diesen Beitrag:
  • Nonexperta
Antworten Top
#7
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.
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
[-] Folgende(r) 1 Nutzer sagt Danke an schauan für diesen Beitrag:
  • Nonexperta
Antworten Top
#8
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.
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste