我最近也遇到类似的问题，就简单写了一个 VBA 插件来稍微简化 将各页中零散的参考文献 集中到最后一页 并自动编号 的过程，虽然不能完全解决题干中的问题，但能减少一些手工的操作。
它的主要功能包括：
- 找到当前 PPT 文件中所有具有指定名称的文本框（认为它们是专门用来填写参考文献的），收集其中的参考文献信息（每行对应一条）。
- 将所有页中找到的参考文献汇总到（新插入的）最后一页，并自动按出现顺序编号（编号格式为 [1], [2], ...）。
- 此外，在最后一页中，还会在每条参考文献的末尾显示它所出现的那些 PPT 的页数（并包含跳转链接）。
- 最后，该插件还会自动为前面的每一页中的参考文献进行重新统一编号。
在 Windows 上的演示效果如下：
在下面的示例中，所有的参考文献文本框都事先被命名为 tb_ref，这也是此插件默认处理的名称。
针对上面的功能4，目前能够识别并修正的编号格式包括以下四种：
[数字] xxxx
【数字】 xxxx
数字. xxxx
*xxxxx ![]()
用 VBA 插件整理 PPT 参考文献
https://www.zhihu.com/video/1553160758443311104
在 macOS 上的演示效果如下：
![]()
用 VBA 插件整理 PPT 参考文献
https://www.zhihu.com/video/1553167203943583744
下面是上述插件中用到的具体 VBA 代码：
注：需要事先将每一页中对应参考文献的文本框名称统一改为 tb_ref（或者其他名字也可以，在下面代码中由 tb_name 变量定义），才能使用下面的代码自动进行处理。 Sub CollectAllRefs()
Dim i, j, p, num_slides, count, slide_id As Long
Dim oSld As Slide
Dim shp As Shape
Dim flag As Boolean
Dim tb_name, tb_text, ret, slide_name As String
Dim to_write() As String
Dim tmp As String
Dim ref_pages() As String
Dim ref_p() As String
'tb_name = InputBox("Please enter the name of textboxes that contain references", "Processing references", "tb_ref")
tb_name = InputBox("请输入含有参考文献的文本框名称", "批量整理参考文献", "tb_ref")
If StrPtr(tb_name) = 0 Then
' User cancels
Exit Sub
End If
ReDim Preserve to_write(0 To 0)
ReDim Preserve ref_pages(0 To 0)
num_slides = ActivePresentation.Slides.Count
For i = 1 To num_slides
Set oSld = ActivePresentation.Slides(i)
' Skip hidden slides
If oSld.SlideShowTransition.Hidden = msoFalse Then
For Each oShp In oSld.Shapes
' Check to see if shape has a text frame and text
If oShp.Name = tb_name And oShp.HasTextFrame And oShp.TextFrame.HasText Then
For p = 1 To oShp.TextFrame.TextRange.Paragraphs.Count
tb_text = oShp.TextFrame.TextRange.Paragraphs(p).Text
tb_text = Replace(tb_text, vbCrLf, "")
tb_text = Replace(tb_text, vbCr, "")
tb_text = Replace(tb_text, vbLf, "")
tb_text = Replace(tb_text, vbNewLine, "")
If Trim(tb_text & vbNullString) <> vbNullString Then
&#39; Not an empty string
ret = ProcessOneString(tb_text, to_write)
If Left(ret, 1) <> &#34;*&#34; Then
&#39; Add a new reference
ReDim Preserve to_write(0 To (UBound(to_write, 1) + 1))
j = UBound(to_write, 1)
to_write(j) = ret
ReDim Preserve ref_pages(0 To (UBound(ref_pages, 1) + 1))
ref_pages(UBound(ref_pages, 1)) = CStr(i)
Else
&#39; Found an existing reference
j = CLng(Mid(ret, 2, Len(ret)))
ret = to_write(j)
ref_pages(j) = ref_pages(j) & &#34;,&#34; & CStr(i)
End If
&#39; Modify the numbering in each slide
count= InStr(1, oShp.TextFrame.TextRange.Paragraphs(p).Text, ret, vbTextCompare)
If count = 0 Then
&#39; This should not happen for normal cases
Debug.Print tb_text & vbNewLine & ret & vbNewLine & &#34;==========&#34; & vbNewLine
End If
With oShp.TextFrame.TextRange.Paragraphs(p)
.Characters(1, count - 1) = &#34;&#34;
.InsertBefore(&#34;[&#34; & j - LBound(to_write) & &#34;] &#34;)
End With
End If
Next p
End If
Next oShp
End If
Next i
Set oSld = ActivePresentation.Slides.Add(Index:=ActivePresentation.Slides.count + 1, Layout:=ppLayoutBlank)
With oSld.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=ActivePresentation.PageSetup.SlideWidth * 0.1, _
Top:=ActivePresentation.PageSetup.SlideHeight * 0.1, _
Width:=ActivePresentation.PageSetup.SlideWidth * 0.8, _
Height:=ActivePresentation.PageSetup.SlideHeight * 0.8 _
).TextFrame
count = 0
For i = LBound(to_write) To UBound(to_write)
If Trim(to_write(i) & vbNullString) <> vbNullString Then
count = count + 1
tmp = &#34;[&#34; & count & &#34;] &#34; & to_write(i) & &#34; &#34;
With .TextRange.InsertAfter(tmp)
.Font.Superscript = msoFalse
End With
&#39; Add link to pages that refer to the references
ref_p = Split(ref_pages(i), &#34;,&#34;)
flag = msoFalse
For j = LBound(ref_p) To UBound(ref_p)
If Trim(ref_p(j) & vbNullString) <> vbNullString Then
If flag Then
With .TextRange.InsertAfter(&#34;, &#34;)
.Font.Superscript = msoTrue
End With
End If
With .TextRange.InsertAfter(ref_p(j))
slide_id = ActivePresentation.Slides(CLng(ref_p(j))).SlideID
slide_name = ActivePresentation.Slides(CLng(ref_p(j))).Name
.ActionSettings(1).Hyperlink.SubAddress = slide_id & &#34;,&#34; & ref_p(j) & &#34;,&#34; & slide_name
.Font.Superscript = msoTrue
End With
flag = msoTrue
End If
Next j
If i < UBound(to_write) Then
With .TextRange.InsertAfter(vbNewLine)
.Font.Superscript = msoFalse
End With
End If
End If
Next i
.AutoSize = ppAutoSizeShapeToFitText
End With
If count > 0 Then
&#39;MsgBox &#34;Added &#34; & count & &#34; references at the end&#34;
MsgBox &#34;已在尾页添加 &#34; & count & &#34; 条参考文献&#34;
Else
oSld.Delete
&#39;MsgBox &#34;No reference is found&#34;
MsgBox &#34;未找到参考文献&#34;
End If
End Sub
Function ProcessOneString(in_text As Variant, all_text As Variant) As String
Dim j As Long
Dim found_match As Boolean
Dim record As String
Dim strPattern As String
#If Mac Then
sMacScript = &#34;set s to &#34;&#34;&#34; & in_text & &#34;&#34;&#34;&#34; & vbNewLine & _
&#34;set srpt to &#34;&#34;echo \&#34;&#34;&#34;&#34; & s & &#34;&#34;\&#34;&#34; | sed -r \&#34;&#34;s/^([0-9]+([[:space:]]|\\.)|[[【][0-9]+[]】]|\\*)[[:space:]]*//\&#34;&#34;&#34;&#34;&#34; & vbNewLine & _
&#34;return (do shell script srpt)&#34;
Debug.Print sMacScript
in_text = MacScript(sMacScript)
#Else
strPattern = &#34;^([0-9]+[\s\.]|[\[【][0-9]+[\]】]|\*)\s*&#34;
Set regEx = CreateObject(&#34;VBScript.RegExp&#34;)
With regEx
.Global = True
.MultiLine = False
.IgnoreCase = True
.Pattern = strPattern
End With
If regEx.TEST(in_text) Then
in_text = regEx.Replace(in_text, &#34;&#34;)
End If
#End If
found_match = msoFalse
For j = LBound(all_text) To UBound(all_text)
record = CStr(all_text(j))
If Trim(record & vbNullString) <> vbNullString Then
If InStr(1, record, in_text, vbTextCompare) > 0 Then
found_match = msoTrue
ProcessOneString = &#34;*&#34; & CStr(j)
Exit For
End If
End If
Next j
If found_match = msoFalse Then
ProcessOneString = in_text
End If
End Function要想使用此代码，一种方式是直接打开「开发者工具」→「Visual Basic」编辑器→「插入」→「模块」，填入上述代码，然后点击三角按钮运行：
![]()
在 Windows 版 PowerPoint 中打开 Visual Basic 编辑器，并插入「模块」
![]()
在 Mac 版 PowerPoint 中打开 Visual Basic 编辑器，并插入「模块」
另一种使用方式是参考下面的文章来制作 VBA 插件：
Emrys：Windows/macOS 上的 PPT 插件自制指南 |
转播
