Sub ZeichenFormatierungKopieren()
'Überträgt das Schriftformat einer mehrzeiligen Zelle mit Zeilenumbruch auf andere Zellen
'04.08.2010, NoNet - www.excelei.de
Dim rngOriginal As Range, rngZelle As Range
Dim intI As Integer, intS As Integer, intT As Integer, intZ As Integer
Dim intZeile(0 To 9) 'Maximal 10 Zeilen pro Zelle
Set rngOriginal = [A1] 'A1 ist die Zelle mit der zu übernehmenden Formatierung
'Zuerst wird ermittelt, wo die Zeilenumbrüche enthalten sind - max. 10 Zeilen pro Zelle :
intZeile(0) = 0: intI = 1
While InStr(intS + 1, rngOriginal.Value, Chr(10)) And intI < 10
intS = InStr(intS + 1, rngOriginal.Value, Chr(10))
intZeile(intI) = intS + 1
intI = intI + 1
Wend
'Die Schriftformatierung des ersten Zeichens je Zeile aus der Originalzelle
'wird auf die entsprechenden Zeilen der markierten Zellen übertragen
'Selection sind die markierten Zellen, auf die das Format übertragen werden soll
For Each rngZelle In Selection
If rngZelle.Value <> "" Then
intT = 0: intZ = 0
Do
intS = intT
intT = InStr(intS + 1, rngZelle.Value, Chr(10))
If intT = 0 Then intT = Len(rngZelle.Value)
With rngZelle.Characters(intS + 1, IIf(intZ >= intI, 255, intT - intS)).Font
.Name = rngOriginal.Characters(intZeile(IIf(intZ < intI, intZ, intI - 1)), 1).Font.Name
.FontStyle = rngOriginal.Characters(intZeile(IIf(intZ < intI, intZ, intI - 1)), 1).Font.FontStyle
.Size = rngOriginal.Characters(intZeile(IIf(intZ < intI, intZ, intI - 1)), 1).Font.Size
.Strikethrough = rngOriginal.Characters(intZeile(IIf(intZ < intI, intZ, intI - 1)), 1).Font.Strikethrough
.Superscript = rngOriginal.Characters(intZeile(IIf(intZ < intI, intZ, intI - 1)), 1).Font.Superscript
.Subscript = rngOriginal.Characters(intZeile(IIf(intZ < intI, intZ, intI - 1)), 1).Font.Subscript
.OutlineFont = rngOriginal.Characters(intZeile(IIf(intZ < intI, intZ, intI - 1)), 1).Font.OutlineFont
.Shadow = rngOriginal.Characters(intZeile(IIf(intZ < intI, intZ, intI - 1)), 1).Font.Shadow
.Underline = rngOriginal.Characters(intZeile(IIf(intZ < intI, intZ, intI - 1)), 1).Font.Underline
.ColorIndex = rngOriginal.Characters(intZeile(IIf(intZ < intI, intZ, intI - 1)), 1).Font.ColorIndex
End With
If intZ < intI Then
intZ = intZ + 1
Else
intZ = intI + 1
End If
Loop While intZ <= intI
End If
Next
End Sub
Ausschlaggebend für die Formatierung ist das erste Zeichen einer Zeile innerhalb der Zelle !
Gruß, NoNet
|