Replace ersetzt ungewollt die Schriftart
20.04.2020 22:58:09
Daniel
nach einigem Durchwühlen des Forums und Probierens komme ich nun leider nicht mehr weiter:
Mein Kalender verbindet die Termine von unterschiedlichen Personen in einem "Gesamtkalender".
Damit die Termine innerhab einer Zelle noch zugeordnet werden können möchte ich nun vor den jeweiligen Termin je nach Nutzer ein zugeordnetes Wingdingssymbol setzen.
Hierzu wird ein Text erstellt und das jeweilige Symbol mit unwahrscheinlichen Zeichen Ø [chrw(216)] und µ [chrw(181)] markiert. Um es deutlich zu machen:
Smiley = Wingdings J
Kalendereintrag (Roh): "ØJµAuto in die Werkstatt"
Nun suche ich nach Ø und µ und "replace" die beiden Zeichen durch " ", über deren Position ändere ich nun die Schriftart des J auf wingdings.
Sub replace()
With Worksheets("Kalender")
posA = InStr(1, .Cells(a.Row, a.Column + 2).Value, ChrW(216), vbTextCompare)
posB = InStr(1, .Cells(a.Row, a.Column + 2).Value, ChrW(181), vbTextCompare)
Do While posA > 0 And posB > 0
.Cells(a.Row, a.Column + 2) = Replace(.Cells(a.Row, a.Column + 2), ChrW(216), "", 1, 1, _
vbTextCompare)
.Cells(a.Row, a.Column + 2) = Replace(.Cells(a.Row, a.Column + 2), ChrW(181), "", 1, 1, _
vbTextCompare)
.Cells(a.Row, a.Column + 2).Characters(Start:=posA, Length:=posB - posA - 1).Font.Name = _
"Wingdings"
posA = InStr(1, .Cells(a.Row, a.Column + 2).Value, ChrW(216), vbTextCompare)
posB = InStr(1, .Cells(a.Row, a.Column + 2).Value, ChrW(181), vbTextCompare)
Loop
End With
End Sub
Sobald nun aber mehrere Termine vorkommen, z.B.
Kalendereintrag (Roh): "ØJµAuto in die Werkstatt // ØzµArzttermin" wird nur das letzte Symbol in Wingdings gesetzt, da beim "replacen" die Schriftart der gesamten Zelle wieder auf Calibri gesetzt wird.
Gibt es dafür eine Lösung?
Danke schön!