Find text section and insert into table - vba

Question

everyone.
I've only been immersed in the world of macros for a few days now and don't really know my way around.
I have several Word 2016 documents that I want to reformat. Each document has exactly the same structure (see attached file).
What I have done so far (and how it works)
Since the images are distorted and too large, I first set them in the same aspect ratio and reduce them to 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
Then I search for the text lines "Slide notes" and replace them with the text "Speaker text:".
And also the text "Text Captions" I replace in the same way, with "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
And now I just can't get any further
Next, on each page, the text between "Speaker text" and "Screen text" should be filled into a table with two columns.
Ideally, the two columns should have a division of 2/3 to 1/3 (at full width).
At each line break, a new table line should be inserted
The table should end with the last entry (before "Screen text:")
This is the script, how I try to create the two-column table but unfortunately not working correctly.
Dim rng As Range
sTx = "Speaker text:"
With ActiveDocument
Set rng = .Range(.Characters(InStr(.Content, sTx) + Len(sTx) + 1).Start, .Characters(InStr(.Content, "Screen text:") - 1).End)
rng.Select
rng.ConvertToTable Separator:=wdSeparateByParagraphs, NumColumns:=1, _
NumRows:=2, InitialColumnWidth:=CentimetersToPoints(5), AutoFitBehavior _
:=wdAutoFitFixed
With rng.Tables(1)
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
'Apply borders around table
.Borders(wdBorderTop).LineStyle = wdLineStyleSingle
.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
.Borders(wdBorderLeft).LineStyle = wdLineStyleSingle
.Borders(wdBorderRight).LineStyle = wdLineStyleSingle
End With
.Tables(1).Range.Columns.Add ' InsertColumnsRight
.Tables(1).Columns(1).SetWidth ColumnWidth:=184.05, RulerStyle:= _
wdAdjustFirstColumn
.Tables(1).Columns(2).SetWidth ColumnWidth:=99.2, RulerStyle:= _
wdAdjustFirstColumn
End With
Unfortunately, it doesn't work the way I want it to.
Only one table is created (on the first page)
Only one frame is visible (no subdivision)
There is always an empty row (table)
The table does not have the full widthe
Before / After

Answer 1

Try:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument.Range
For i = 1 To .InlineShapes.Count
With .InlineShapes(i)
.ScaleHeight = 50
.ScaleWidth = 50
End With
Next i
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "Slide notes*Text Captions"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
End With
Do While .Find.Execute
.Paragraphs.First.Range.Text = "Speaker text:"
.Paragraphs.Last.Range.Text = "Screen text:" & vbCr
.Start = .Paragraphs.First.Range.End
.End = .Paragraphs.Last.Range.Start
Do While .Characters.First.Text = vbCr
.Characters.First.Delete
Loop
With .Duplicate
.Find.Execute FindText:="^13^13", ReplaceWith:="^t^p", Replace:=wdReplaceAll
.ConvertToTable Separator:=vbTab, NumRows:=.Paragraphs.Count, NumColumns:=2, AutoFitBehavior:=wdAutoFitWindow
With .Tables(1)
.AllowAutoFit = False
.PreferredWidthType = wdPreferredWidthPoints
.Borders.Enable = True
.Rows(1).HeadingFormat = True
.Columns(1).SetWidth ColumnWidth:=.PreferredWidth * 2 / 3, RulerStyle:=wdAdjustProportional
Do While .Range.Characters.Last.Next = vbCr
.Range.Characters.Last.Next.Delete
Loop
End With
End With
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
End Sub

Answer 2

#macropod
May I ask you to explain your script to me.
The first part (the proportional reduction of the images) is clear so far.
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument.Range
For i = 1 To .InlineShapes.Count
With .InlineShapes(i)
.ScaleHeight = 50
.ScaleWidth = 50
End With
With the second section (replacing the two phrases), I already have more problems.
Next i
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "Slide notes*Text Captions"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
End With
Do While .Find.Execute
.Paragraphs.First.Range.Text = "Speaker text:"
.Paragraphs.Last.Range.Text = "Screen text:" & vbCr
.Start = .Paragraphs.First.Range.End
.End = .Paragraphs.Last.Range.Start
Do While .Characters.First.Text = vbCr
.Characters.First.Delete
Loop
And I am hopelessly overwhelmed with the last part.
With .Duplicate
.Find.Execute FindText:="^13^13", ReplaceWith:="^t^p", Replace:=wdReplaceAll
.ConvertToTable Separator:=vbTab, NumRows:=.Paragraphs.Count, NumColumns:=2, AutoFitBehavior:=wdAutoFitWindow
With .Tables(1)
.AllowAutoFit = False
.PreferredWidthType = wdPreferredWidthPoints
.Borders.Enable = True
.Rows(1).HeadingFormat = True
.Columns(1).SetWidth ColumnWidth:=.PreferredWidth * 2 / 3, RulerStyle:=wdAdjustProportional
Do While .Range.Characters.Last.Next = vbCr
.Range.Characters.Last.Next.Delete
Loop
End With
End With
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
Please excuse me for inquiring. But I would like to understand the script.
Because I would also like to rewrite the script so that I can use it without the "Screen text:" section.
Thank you very much and best regards.