Formatierung beibehalten

Hallo zusammen,
ich habe folgendes Problem:
folgendes steht bereits in der Excel Zelle
2014-10-21_hofackerd:
Text1
2014-11-18_hofackerd:
Text2
Nun soll durch ein Makro eine weitere Überschrift hinzugefügt werden, wobei diese ebenfalls kursiv geschrieben sein soll und der Nutzer der nun Text3 eingeben würde sollte nicht kursiv weiter schreiben können.
Des jetzige Makro sieht wie folgt aus:
Dim TXT, N, D
Dim laenge As Integer
Dim start As Integer
TXT = ActiveCell.Value
N = "_gersdorfo:"
D = Format(Date, "yyyy-mm-dd")
start = Len(TXT) + 1
laenge = Len(vbCrLf & vbCrLf & D & N)
ActiveCell.Value = TXT & vbCrLf & vbCrLf & D & N & vbCrLf
ActiveCell.Characters(start:=start, Length:=laenge).Font.FontStyle = "Kursiv"
End Sub
Leider wird der bereits vorhandene Text beim Anwenden des Makros komplett kursiv oder komplett normal geschrieben. Wie bekomme ich es hin das der vorhandene Text seine Formatierung behält?
Vielen Dank im Vorraus
Gruß Carsten

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Carsten,
man muss die Fontinformationen im Text der Zelle vor dem Einfügen des neuen Textes zwischenspeichern und danach wieder herstellen.
Das ist schon relativ kompliziert, da dynamisch wachsende Daten-Arrays zur Speicherung der Daten verwaltet werden muss.
Gruß
Franz

Sub ZelleBearbeiten()
Dim TXT As String, N As String, D As String, strFontstyle As String
Dim arrPos() As Integer, arrFontStyle() As String
Dim intK As Integer, intPos As Integer
Dim laenge As Integer
Dim start As Integer
Dim Zelle As Range
Set Zelle = ActiveCell
TXT = Zelle.Text
N = "_gersdorfo:"
D = Format(Date, "yyyy-mm-dd")
If TXT = "" Then
start = Len(TXT) + 1
laenge = Len(D & N)
Zelle.Value = D & N & vbCrLf
Else
For intPos = 1 To Len(TXT)
If strFontstyle  Zelle.Characters(intPos, 1).Font.FontStyle Then
intK = intK + 1
ReDim Preserve arrPos(1 To intK)
ReDim Preserve arrFontStyle(1 To intK)
strFontstyle = Zelle.Characters(intPos, 1).Font.FontStyle
arrPos(intK) = intPos
arrFontStyle(intK) = strFontstyle
End If
Next
start = Len(TXT) + 1
laenge = Len(vbCrLf & vbCrLf & D & N)
Zelle.Value = TXT & vbCrLf & vbCrLf & D & N & vbCrLf
End If
Zelle.Font.FontStyle = "Standard"
If intK > 0 Then
For intK = 1 To UBound(arrPos)
If intK = UBound(arrPos) Then
Zelle.Characters(arrPos(intK), start - arrPos(intK)).Font.FontStyle _
= arrFontStyle(intK)
Else
Zelle.Characters(arrPos(intK), arrPos(intK + 1) - arrPos(intK)) _
.Font.FontStyle = arrFontStyle(intK)
End If
Next
End If
Zelle.Characters(start:=start, Length:=laenge).Font.FontStyle = "Kursiv"
Erase arrPos, arrFontStyle
End Sub

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread