查找文本部分并插入表格

Question

每个人。

我现在才沉浸在宏的世界中几天，并不真正了解我的方式。 我有几个想要重新格式化的 Word 2016 文档。每个文档都有完全相同的结构（见附件）。

到目前为止我做了什么（以及它是如何工作的） 由于图像失真且太大，我先将它们设置为相同的纵横比，然后将它们缩小到 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

然后我搜索文本行“幻灯片注释”并将它们替换为文本“演讲者文本：”。 还有我用同样的方式替换的文本“文本标题”，用“屏幕文本：”

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

现在我无法再进一步了 接下来，在每一页上，“Speaker text”和“Screen text”之间的文本应该被填充到一个有两列的表格中。

• 理想情况下，两列的间隔应为 2/3 到 1/3（全宽）。
• 在每个换行符处，应插入一个新的表格行
• 表格应以最后一个条目结束（在“屏幕文本：”之前）

这是脚本，我如何尝试创建两列表，但不幸的是无法正常工作。

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

很遗憾，它没有按我想要的方式工作。

• 只创建一个表（在第一页上）
• 只有一帧可见（无细分）
• 总是有一个空行（表格）
• 表格没有全宽e

之前/之后

Answer 1

试试：

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 我可以请你向我解释你的剧本吗？ 到目前为止，第一部分（图像的比例缩小）很清楚。 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

请原谅我的询问。但我想了解脚本。 因为我还想重写脚本，这样我就可以在没有“屏幕文本：”部分的情况下使用它。 非常感谢和最好的问候。