Sub SlideNoteToTable()
'
' SlideNoteToTable Macro
' Formats the speaker text into a two-column table
'
' -----------------< Reduce all images proportionally by 50% >-----------------
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
' -----------------< Change "Slide notes" and "Text Captions" to ---------
' -----------------  "Speaker text:" and "Screen text:" >-----------------
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
' -----------------< Create Table >-----------------
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
'Startpunkte für die Tabellenbereiche sammeln (Speaker Text- Ende)
Set suchBereich = ActiveDocument.Range
    With suchBereich.Find
        .Text = "Speaker Text"
            Do While .Execute
                collStart.Add suchBereich.Paragraphs(1).Range.End + 1
            Loop
    End With
' Endpunkte für die Tabellenbereiche sammeln (Screen- Text Anfang)
Set suchBereich = ActiveDocument.Range
    With suchBereich.Find
        .Text = "Screen Text"
            Do While .Execute
                collEnd.Add suchBereich.Start - 1
            Loop
    End With
'Bereiche in Tabelle verwandeln
    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
                'hier alle Tabellenformatierungsoperationen
                .AllowAutoFit = False
                .PreferredWidthType = wdPreferredWidthPoints
                .Borders.Enable = True
                .Rows(1).HeadingFormat = True
                .Columns(1).SetWidth ColumnWidth:=.PreferredWidth * 2 / 3, RulerStyle:=wdAdjustProportional
            End With
        Next d
' -----------------< Delete empty tables >-----------------
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 'dann ist nur eine leere Absatzmarke drin
            zeile.Delete
        End If
    Next zeile
Next tabelleX
End Sub