Makro mit Superscript-Zahlen für Tabellenspalten

[ernst]

Hallo Experten,

Wie kann ich ein Makro in VBA machen, das z.B. diese Tabellenspalten (f:
fett geschrieben)

f: Abend
f: Abend
f: Abend
f: Abend
am Abend
f: Abend

f: aber
Ja, aber nur sehr wenig.
Küken können zwar mit ihren Flügeln schlagen, aber …
f: aber
Es fährt nur so (aber nie anders).
Ja, aber nur sehr wenig.
f: aber
f: aber

so wie unten angegeben umwandeln kann. Die fett geschriebenen Wörter
sollen fett bleiben, die normal geschriebenen normal. Die Farbe der
Hochzahlen soll blau und fett sein

f: Abend¹
f: Abend²
f: Abend³
f: Abend⁴
am Abend
f: Abend⁵

f: aber¹
Ja, aber nur sehr wenig.
Küken können zwar mit ihren Flügeln schlagen, aber …
f: aber²
Es fährt nur so (aber nie anders).
Ja, aber nur sehr wenig.
f: aber³
f: aber⁴

Danke für Tips.

Ernst

[Thomas Gahler]

Hallo ernst

f: Abend?

Und was bedeuten diese Kästchen?

[Thomas Gahler]

Hallo ernst

fett geschrieben) [...]

Vielleicht ungefähr so...




Sub Demo()
Dim doc As Word.Document
Dim tbl As Word.Table
Dim cel As Word.Cell
Set doc = ActiveDocument

For Each tbl In doc.Tables
For Each cel In tbl.Range.Cells
procZelleBearbeiten c:=cel
Next cel
Next tbl
End Sub

Private Sub procZelleBearbeiten( _
ByVal c As Word.Cell)

Dim rng As Word.Range
Dim strFeldName As String

If c.Range.Font.Bold Then
strFeldName = funcSEQNameBestimmen(str:=c.Range.Text)

Set rng = c.Range
rng.SetRange Start:=c.Range.End - 1, End:=c.Range.End - 1

rng.Fields.Add Range:=rng, Type:=wdFieldSequence, Text:=strFeldName
rng.SetRange Start:=c.Range.End - 2, End:=c.Range.End - 1
rng.Select

With Selection.Font
.Bold = True
.Superscript = True
.Color = wdColorBlue
End With
End If
End Sub

Private Function funcSEQNameBestimmen( _
ByVal str As String) _
As String

str = Mid$(str, 1, Len(str) - 2)
str = Trim$(str)
If Len(str) = 0 Then
str = Format$(Now, "yyyymmdd")
End If
str = Chr$(34) & str & Chr$(34)

funcSEQNameBestimmen = str
End Function

[ernst]

Post by Thomas Gahler
Hallo ernst

fett geschrieben) [...]

Vielleicht ungefähr so...
Sub Demo()
Dim doc As Word.Document
Dim tbl As Word.Table
Dim cel As Word.Cell
Set doc = ActiveDocument
For Each tbl In doc.Tables
For Each cel In tbl.Range.Cells
procZelleBearbeiten c:=cel
Next cel
Next tbl
End Sub
Private Sub procZelleBearbeiten( _
ByVal c As Word.Cell)
Dim rng As Word.Range
Dim strFeldName As String
If c.Range.Font.Bold Then
strFeldName = funcSEQNameBestimmen(str:=c.Range.Text)
Set rng = c.Range
rng.SetRange Start:=c.Range.End - 1, End:=c.Range.End - 1
rng.Fields.Add Range:=rng, Type:=wdFieldSequence, Text:=strFeldName
rng.SetRange Start:=c.Range.End - 2, End:=c.Range.End - 1
rng.Select
With Selection.Font
.Bold = True
.Superscript = True
.Color = wdColorBlue
End With
End If
End Sub
Private Function funcSEQNameBestimmen( _
ByVal str As String) _
As String
str = Mid$(str, 1, Len(str) - 2)
str = Trim$(str)
If Len(str) = 0 Then
str = Format$(Now, "yyyymmdd")
End If
str = Chr$(34)& str& Chr$(34)
funcSEQNameBestimmen = str
End Function

Hallo Thomas,

ich möchte dir für dieses Makro herzlich danken. Es funktioniert
ausgezeichnet. Selbst bei sehr langen Tabellen.

Ich hätte das so gut nie hin bekommen.

Gruß
Ernst Tremel