请求基于Excel指定顺序排序Word形状内容的VBA脚本

没问题，我帮你搞定这个需求！下面的VBA脚本完全按照你描述的逻辑来：把Word形状里的内容按「Type X+关联内容」分组，然后对照Excel Sheet2的A列顺序重新排列这些分组，最后把整理好的内容放回形状里。

完整VBA脚本 #

Sub SortShapesContentBasedOnExcelOrder()
    Dim doc As Document
    Dim shp As Shape
    Dim xlApp As Object
    Dim xlWB As Object
    Dim typeOrder As Collection
    Dim contentGroups As Collection
    Dim groupItem As Variant
    Dim orderItem As Variant
    Dim currentContent As String
    Dim currentType As String
    Dim newContent As String
    Dim i As Integer
    Dim lines() As String
    Dim line As Variant
    Dim lastLineIndex As Integer
    
    ' 设置当前Word文档
    Set doc = ActiveDocument
    
    ' 打开/连接Excel并获取指定工作簿
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
        xlApp.Visible = True ' 显示Excel方便确认顺序
    End If
    On Error GoTo 0
    Set xlWB = xlApp.ActiveWorkbook
    If xlWB Is Nothing Then
        MsgBox "请先打开包含排序规则的Excel文件！", vbExclamation
        Exit Sub
    End If
    
    ' 读取Excel Sheet2的A列排序规则（跳过空行）
    Set typeOrder = New Collection
    For i = 1 To xlWB.Sheets(2).Cells(xlWB.Sheets(2).Rows.Count, 1).End(-4162).Row
        If Trim(xlWB.Sheets(2).Cells(i, 1).Value) <> "" Then
            typeOrder.Add Trim(xlWB.Sheets(2).Cells(i, 1).Value)
        End If
    Next i
    
    ' 遍历Word形状，提取内容并按Type分组
    Set contentGroups = New Collection
    newContent = "" ' 初始化最终内容
    For Each shp In doc.Shapes
        If shp.TextFrame.HasText Then
            currentContent = shp.TextFrame.TextRange.Text
            lines = Split(currentContent, vbCrLf)
            
            currentType = ""
            Dim tempGroup As String
            tempGroup = ""
            
            ' 拆分内容为Type分组
            For Each line In lines
                ' 判断当前行是否为Type开头（可根据实际关键词修改判断逻辑）
                If InStr(1, line, "Type ", vbTextCompare) = 1 Then
                    ' 先保存上一个Type的分组
                    If currentType <> "" Then
                        contentGroups.Add Array(currentType, tempGroup)
                    End If
                    currentType = line
                    tempGroup = line & vbCrLf
                Else
                    ' 非Type行，加入当前分组；如果还没遇到第一个Type，直接保留到开头
                    If currentType <> "" Then
                        tempGroup = tempGroup & line & vbCrLf
                    Else
                        newContent = newContent & line & vbCrLf
                    End If
                End If
            Next line
            
            ' 保存最后一个Type分组
            If currentType <> "" Then
                contentGroups.Add Array(currentType, tempGroup)
            End If
            
            ' 提取最后一个Type之后的内容（比如示例里的Type3后续内容）
            lastLineIndex = UBound(lines)
            Dim trailingContent As String
            trailingContent = ""
            Do While lastLineIndex >= 0
                If InStr(1, lines(lastLineIndex), "Type ", vbTextCompare) = 1 Then
                    Exit Do
                End If
                trailingContent = lines(lastLineIndex) & vbCrLf & trailingContent
                lastLineIndex = lastLineIndex - 1
            Loop
            newContent = newContent & trailingContent
        End If
    Next shp
    
    ' 按照Excel的顺序重新排列Type分组
    For Each orderItem In typeOrder
        For i = contentGroups.Count To 1 Step -1
            groupItem = contentGroups(i)
            If groupItem(0) = orderItem Then
                newContent = newContent & groupItem(1)
                contentGroups.Remove i ' 移除已处理的分组避免重复
                Exit For
            End If
        Next i
    Next orderItem
    
    ' 追加未在Excel排序规则里的Type分组（比如示例里的Type3）
    For Each groupItem In contentGroups
        newContent = newContent & groupItem(1)
    Next groupItem
    
    ' 清理多余的换行符
    If Len(newContent) > 2 Then
        newContent = Left(newContent, Len(newContent) - 2)
    End If
    
    ' 将整理好的内容放回所有Word形状
    For Each shp In doc.Shapes
        If shp.TextFrame.HasText Then
            shp.TextFrame.TextRange.Text = newContent
        End If
    Next shp
    
    ' 释放对象
    Set xlWB = Nothing
    Set xlApp = Nothing
    Set contentGroups = Nothing
    Set typeOrder = Nothing
    Set doc = Nothing
    
    MsgBox "形状内容已按Excel顺序排序完成！", vbInformation
End Sub

使用说明 #

• 1. 先打开目标Word文档和包含排序规则的Excel文件（确保Excel的Sheet2的A列是你需要的Type顺序）
• 2. 打开Word的VBA编辑器：按下Alt + F11
• 3. 插入新模块：右键点击当前文档节点 → 插入 → 模块
• 4. 把上面的代码粘贴到模块中
• 5. 运行宏：按下F5或者点击编辑器工具栏的运行按钮

自定义提示 #

• 如果你的Type关键词不是「Type 」，比如是「分类：」，直接修改代码中InStr(1, line, "Type ", vbTextCompare) = 1这部分的关键词即可
• 若Word中每个形状是独立的内容组，需要调整遍历形状的逻辑，单独处理每个形状的内容拆分与排序
• 若要指定固定路径的Excel文件，可把Set xlWB = xlApp.ActiveWorkbook替换为Set xlWB = xlApp.Workbooks.Open("C:\你的Excel文件路径.xlsx")

备注：内容来源于stack exchange，提问作者VKK