问题原因 #

1. 原代码仅清空二级段落的内容，并未删除段落本身，这些空段落留在行内，后续InsertAfter插入新内容时会追加在空段落之后，最终形成多余的空段落。
2. Word表格行的最后一个段落标记是行结构的核心部分，直接删除该标记会触发整行内容被清空，这就是para.Range.Delete无效、选中删除会删整行的原因。

修正代码 #

Sub ShuffleLevel2ListInTableRow()
    Dim tbl As Table
    Dim curRow As Row
    Dim para As Paragraph
    Dim paras() As String
    Dim cnt As Integer
    Dim i As Integer, j As Integer
    Dim temp As String

    If Not Selection Is Nothing And Selection.Tables.Count > 0 Then
        Set tbl = Selection.Tables(1)
        Set curRow = Selection.Rows(1)
    Else
        MsgBox "请将光标置于表格内。"
        Exit Sub
    End If

    ' 统计并收集二级列表项，同时删除原段落
    cnt = 0
    ' 反向循环删除段落，避免正向循环时集合索引混乱
    For i = curRow.Range.Paragraphs.Count To 1 Step -1
        Set para = curRow.Range.Paragraphs(i)
        If para.Range.ListFormat.ListLevelNumber = 2 Then
            cnt = cnt + 1
            ReDim Preserve paras(1 To cnt)
            ' 去除文本末尾的段落标记（vbCr）
            paras(cnt) = Left(para.Range.Text, Len(para.Range.Text) - 1)
            para.Range.Delete
        End If
    Next i

    ' 打乱数组
    Randomize
    For i = 1 To cnt - 1
        j = Int((cnt - i + 1) * Rnd + i)
        temp = paras(i)
        paras(i) = paras(j)
        paras(j) = temp
    Next i

    ' 插入打乱后的二级列表项
    For i = 1 To cnt
        With curRow.Range
            .Collapse wdCollapseEnd
            .Text = paras(i) & vbCr
            ' 应用二级列表格式
            .ListFormat.ListLevelNumber = 2
        End With
    Next i

    ' 清理最后可能的空段落（仅处理无内容的段落）
    Set para = curRow.Range.Paragraphs(curRow.Range.Paragraphs.Count)
    ' 仅当段落只有标记（长度为1）时删除
    If Len(para.Range.Text) = 1 Then
        para.Range.Delete
    End If
End Sub

关键改动说明 #

• 反向循环删除原段落：正向删除段落会打乱Paragraphs集合的索引，反向循环可以避免这个问题，彻底移除原二级段落，不留空结构。
• 去除段落标记再插入：原文本末尾的段落标记会导致插入时额外生成段落，用Left截取掉后再添加vbCr，保证插入的内容格式正确。
• 精准清理空段落：判断最后段落是否仅包含段落标记（无实际内容），再执行删除操作，避免破坏表格行的结构。

内容的提问来源于stack exchange，提问作者traveh