Sub SlideNoteToTable()
Dim i As Long
With ActiveDocument
For i = 1 To .InlineShapes.Count
With .InlineShapes(i)
.ScaleHeight = 50
.ScaleWidth = 50
End With
Next i
End With
Set myRange = ActiveDocument.Content
myRange.Find.Execute FindText:="Slide notes", _
ReplaceWith:="Speaker text:", Replace:=wdReplaceAll
Set myRange = ActiveDocument.Content
myRange.Find.Execute FindText:="Text Captions", _
ReplaceWith:="Screen text:", Replace:=wdReplaceAll
Dim suchBereich As Range, TabBereich As Range, tabelle As Table
Dim collStart As Collection, collEnd As Collection
Dim d As Long
Set collStart = New Collection: Set collEnd = New Collection
Set suchBereich = ActiveDocument.Range
With suchBereich.Find
.Text = "Speaker Text"
Do While .Execute
collStart.Add suchBereich.Paragraphs(1).Range.End + 1
Loop
End With
Set suchBereich = ActiveDocument.Range
With suchBereich.Find
.Text = "Screen Text"
Do While .Execute
collEnd.Add suchBereich.Start - 1
Loop
End With
For d = collStart.Count To 1 Step -1
Set TabBereich = ActiveDocument.Range(collStart(d), collEnd(d))
Set tabelle = TabBereich.ConvertToTable(Separator:=wdSeparateByParagraphs, NumColumns:=2, AutoFitBehavior:=wdAutoFitWindow)
With tabelle
.AllowAutoFit = False
.PreferredWidthType = wdPreferredWidthPoints
.Borders.Enable = True
.Rows(1).HeadingFormat = True
.Columns(1).SetWidth ColumnWidth:=.PreferredWidth * 2 / 3, RulerStyle:=wdAdjustProportional
End With
Next d
Dim tabelleX As Table, zeile As Row
For Each tabelleX In ActiveDocument.Tables
For Each zeile In tabelleX.Rows
If Len(zeile.Range) = 4 Then
zeile.Delete
End If
Next zeile
Next tabelleX
End Sub