需求：编写VBA代码按指定列表重排Word中PDF页面并另存

我有一份500+页面的PDF文件，每页都带有唯一编号。一开始尝试用Acrobat PDF Pro DC的Actions/JavaScript功能排序，但完全不懂JavaScript，操作难度极大。后来发现这份PDF可以在MS Word 365中打开且内容可搜索，现在需要一段VBA代码，按照我提供的XLSX、CSV或TXT格式的页面编号列表重新排列页面，并另存为新文件。

相关效果说明：

• 排序前文件：原始PDF的页面按原有编号顺序排列
• 排序列表：包含需要调整到的目标页面编号顺序
• 排序后文件：页面按指定列表顺序重新排列完成的效果

以下是适配MS Word 365的VBA代码，支持读取XLSX/CSV/TXT格式的排序列表，完成页面重排：

Sub ReorderPDFPagesInWord()
    Dim sourceDoc As Document
    Dim targetOrder As Variant
    Dim filePath As String
    Dim fileType As String
    Dim i As Integer, j As Integer
    Dim tempRange As Range
    Dim newDoc As Document
    
    ' 选择要重排的原始PDF文件
    filePath = Application.GetOpenFilename("PDF Files (*.pdf), *.pdf", , "选择原始PDF文件")
    If filePath = False Then Exit Sub
    Set sourceDoc = Documents.Open(filePath)
    
    ' 选择排序列表文件
    filePath = Application.GetOpenFilename("排序文件 (*.xlsx;*.csv;*.txt), *.xlsx;*.csv;*.txt", , "选择排序列表文件")
    If filePath = False Then
        sourceDoc.Close SaveChanges:=False
        Exit Sub
    End If
    
    ' 根据文件类型读取排序顺序
    fileType = LCase(Right(filePath, 4))
    Select Case fileType
        Case "xlsx"
            Dim xlApp As Object, xlWB As Object
            Set xlApp = CreateObject("Excel.Application")
            xlApp.Visible = False
            Set xlWB = xlApp.Workbooks.Open(filePath)
            targetOrder = xlWB.Sheets(1).UsedRange.Value
            xlWB.Close False
            xlApp.Quit
            Set xlWB = Nothing: Set xlApp = Nothing
        Case ".csv", ".txt"
            Dim ff As Integer
            ff = FreeFile
            Open filePath For Input As #ff
            targetOrder = Split(Input$(LOF(ff), ff), vbCrLf)
            Close #ff
        Case Else
            MsgBox "不支持的文件格式！"
            sourceDoc.Close SaveChanges:=False
            Exit Sub
    End Select
    
    ' 创建新文档存放重排内容
    Set newDoc = Documents.Add
    
    ' 遍历排序列表，复制对应页面到新文档
    For i = LBound(targetOrder) To UBound(targetOrder)
        ' 跳过空行
        If Trim(targetOrder(i, 1)) <> "" Then
            ' 定位到目标页面
            sourceDoc.Bookmarks("\Page").Range.GoTo What:=wdGoToPage, Name:=targetOrder(i, 1)
            Set tempRange = sourceDoc.Bookmarks("\Page").Range
            ' 复制页面内容
            tempRange.Copy
            newDoc.Range.Paste
            ' 非最后一页添加分页符
            If i < UBound(targetOrder) Then
                newDoc.Range.InsertBreak Type:=wdPageBreak
            End If
        End If
    Next i
    
    ' 另存为新PDF
    newDoc.SaveAs2 Filename:=Replace(sourceDoc.FullName, ".pdf", "_重排后.pdf"), FileFormat:=wdFormatPDF
    MsgBox "页面重排完成，已生成新PDF文件！"
    
    ' 清理资源
    sourceDoc.Close SaveChanges:=False
    newDoc.Close SaveChanges:=False
    Set sourceDoc = Nothing: Set newDoc = Nothing: Set tempRange = Nothing
End Sub

1. 打开MS Word 365，按下Alt + F11打开VBA编辑器
2. 插入新模块，将上述代码粘贴进去
3. 运行ReorderPDFPagesInWord宏，按提示依次选择原始PDF文件和排序列表文件
4. 等待处理完成，新文件会保存在原始PDF同目录下，命名为「原文件名_重排后.pdf」

• 排序列表要求：XLSX仅需第一列是页面编号；CSV/TXT每行一个页面编号，确保编号与PDF页面上的唯一编号完全匹配
• 大文件处理耗时较长，请不要中途关闭Word
• 操作前请备份原始PDF文件，避免数据丢失

内容的提问来源于stack exchange，提问作者Accounts-Loves-Code