AW: F2 als Makro
22.11.2010 19:14:12
JogyB
Hallo Rolli,
anbei mal ein Makro, bei dem sich das Hoch/Tiefstellen mittels Steuerzeichen im Text erledigen lässt:
' Stellt Zeichen in den markierten Zellen hoch und tief
' Markierung:
' Hoch: ^
' Tief: ´
' Ende des zu formatierenden Bereich: |
' Hoch/Tief ignorieren: '
Public Sub HochTief()
' === Definieren der Markierungszeichen ===
Const hochMark = "^"
Const tiefMark = "´"
Const endMark = "|"
Const ignMark = "'"
' === Ende Definition der Markierungszeichen ===
Dim zeLLe As Range
Dim lenGTH As Long
Dim i As Long
Dim j As Long
Dim delMark() As Long
Dim isUp As Boolean
Dim isDown As Boolean
Dim zielRange As Range
Dim preserveFormat() As zellenFormate
'On Error GoTo errorhandler
Application.ScreenUpdating = False
' Speichert den Bereich zwischen
Set zielRange = Selection
' Für jede Zelle im Bereich
For Each zeLLe In zielRange
lenGTH = Len(zeLLe.Value)
isUp = False
isDown = False
j = 1
ReDim delMark(0 To j)
For i = 1 To lenGTH
' Falls ein Ignorierzeichen kommt
If zeLLe.Characters(i, 1).Caption = ignMark And i lenGTH Then
' Überprüfen, ob das darauffolgende Zeichen überhaupt ein zu ignorierendes Zeichen _
wäre
' a) nächstes Zeichen Hoch/Tiefmarke, Hochtiefmodus aus
' b) nächstes Zeichen Endmarke, Hochtiefmodus an
' c) nächstes Zeichen Ignoremarke
If (InStr(1, hochMark & tiefMark, zeLLe.Characters(i + 1, 1).Caption) And Not ( _
isUp Or isDown)) _
Or (zeLLe.Characters(i + 1, 1).Caption = endMark And (isUp Or isDown)) _
Or zeLLe.Characters(i + 1, 1).Caption = ignMark Then
' Falls ja
' Zur Löschung markieren
ReDim Preserve delMark(0 To j)
delMark(j) = i
j = j + 1
' Nächstes Zeichen überspringen
i = i + 1
End If
' Falls nein: Nix weiter, Ignoremarke nicht auswerten
' formatierung:
' Fall 1: Da das nächste Zeichen bei der Bearbeitung übersprungen wird, würde es
' nicht formatiert, daher hier formatieren
' Fall 2: Das Ignore-Zeichen ignoriert nichts, bleibt also so stehen, daher muss _
das
' aktuelle Zeichen formatiert werden
' i steht in jedem Fall auf dem richtigen Zeichen, paßt also.
If isUp = True Then
' Hochstellen
zeLLe.Characters(i, 1).Font.Superscript = True
ElseIf isDown = True Then
' Tiefstellen
zeLLe.Characters(i, 1).Font.Subscript = True
End If
' Falls Endzeichen kommt
ElseIf zeLLe.Characters(i, 1).Caption = endMark Then
' Endzeichen wird ignoriert, wenn zuvor kein Startzeichen vorhanden ist
If isUp = True Or isDown = True Then
isUp = False
isDown = False
' Wenn eine Löschmarke auf einem Zeichen zuvor steht, dann steht direkt vor dem
' Endzeichen ein Hoch/Tiefstellzeichen --> sinnlos, also ignorieren
' Hinweis: Ein Ignorierzeichen kann es nicht gewesen sein, da sonst das
' aktuelle Zeichen gar nicht geprüft worden wäre
If delMark(j - 1) i - 1 Then
ReDim Preserve delMark(0 To j)
delMark(j) = i
j = j + 1
Else
j = j - 1
ReDim Preserve delMark(0 To j)
delMark(j) = 0
End If
End If
' Wenn im Hochstellmodus, dann...
ElseIf isUp = True Then
' Hochstellen
zeLLe.Characters(i, 1).Font.Superscript = True
' Wenn im Tiefstellmodus, dann...
ElseIf isDown = True Then
' tiefstellen
zeLLe.Characters(i, 1).Font.Subscript = True
ElseIf i lenGTH Then
' Falls weder im Hoch/Tiefstellmodus, dann nach neuem Zeichen schauen
' (Achtung: Endmarke und Ignoremarke werden oben behandelt)
' ignoriert Steuerzeichen am Ende der Zeichenfolge
Select Case zeLLe.Characters(i, 1).Caption
Case hochMark
isUp = True
ReDim Preserve delMark(0 To j)
delMark(j) = i
j = j + 1
Case tiefMark
isDown = True
ReDim Preserve delMark(0 To j)
delMark(j) = i
j = j + 1
End Select
End If
Next
If lenGTH delMark(j) Then
zeLLe.Characters(Start:=i, lenGTH:=1).Caption = preserveFormat(i + j - 1). _
zeiCHen
With zeLLe.Characters(Start:=i, lenGTH:=1).Font
.Name = preserveFormat(i + j - 1).Name
.FontStyle = preserveFormat(i + j - 1).FontStyle
.Size = preserveFormat(i + j - 1).Size
.Strikethrough = preserveFormat(i + j - 1).Strikethrough
.Superscript = preserveFormat(i + j - 1).Superscript
.Subscript = preserveFormat(i + j - 1).Subscript
.OutlineFont = preserveFormat(i + j - 1).OutlineFont
.Shadow = preserveFormat(i + j - 1).Shadow
.Underline = preserveFormat(i + j - 1).Underline
.ColorIndex = preserveFormat(i + j - 1).ColorIndex
End With
Else
j = j + 1
i = i - 1
End If
Next
End If
' Überprüfen, ob zellinhalt numerisch ist und ob die Zelle bearbeitet wurde (j>1)
' Wenn ja, dann muss das Zellenformat auf Text gesetzt werden
If IsNumeric(zeLLe.Value) And j > 1 Then zeLLe.NumberFormat = "@"
Next
End Sub
Den Code kann man unter Umständen noch optimieren (ist schon ein paar Jährchen alt), aber er funktioniert.
Gruß, Jogy