Formatierung beibehalten

Forumthread: Formatierung beibehalten

25.11.2014 11:16:29

Carsten

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

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Formatierung beibehalten

25.11.2014 14:22:55

fcs
AW: Formatierung beibehalten

25.11.2014 14:32:05

Carsten

AW: Formatierung beibehalten

25.11.2014 14:22:55

fcs

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

AW: Formatierung beibehalten

25.11.2014 14:32:05

Carsten

Franz... MEGA!!! Funktioniert perfekt. Danke für deine Hilfe!

Beliebteste Forumthreads (12 Monate)

Forumthread: Formatierung beibehalten

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

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread