Excel勾选姓名按姓氏排序插入Word三列动态表格的VBA问题

• 改用数组存储勾选的姓名，同时存储用于排序的「姓氏,名字」格式和最终要展示的「名字 姓氏」格式，保证排序逻辑正确的同时输出符合要求的格式
• 排序完成后根据勾选人数自动计算Word三列表格的行数：若勾选n人，行数为WorksheetFunction.RoundUp(n / 3, 0)，实现动态行数适配
• 直接将排序后的姓名批量填充到Word表格中，避免多余的文本操作

Sub ExportCheckedNamesToWordTable()
    Dim cl As Range, nameArr() As String, sortArr() As String, i As Long, totalCount As Long
    Dim wdApp As Word.Application, wdDoc As Word.Document, wdTable As Word.Table
    Dim rowNum As Long, colNum As Long, currentIdx As Long
    
    ' 第一步：遍历复选框，收集勾选的姓名
    totalCount = 0
    For Each cl In ThisWorkbook.Worksheets(1).Range("D6:D122")
        If cl.Value = True Then
            Dim tempName As Variant
            tempName = VBA.Split(cl.Offset(0, -2), " ") ' 读取对应位置的姓名，按空格拆分
            ReDim Preserve nameArr(0 To totalCount)
            ReDim Preserve sortArr(0 To totalCount)
            ' sortArr用于排序，格式为 姓,名
            sortArr(totalCount) = tempName(1) & ", " & tempName(0)
            ' nameArr用于最终展示，格式为 名 姓
            nameArr(totalCount) = tempName(0) & " " & tempName(1)
            totalCount = totalCount + 1
        End If
    Next cl
    
    If totalCount = 0 Then Exit Sub ' 没有勾选内容直接退出
    
    ' 第二步：按姓氏拼音/字母序排序
    Call SortTwoArrays(sortArr, nameArr)
    
    ' 第三步：生成Word文档并创建动态三列表格
    Set wdApp = New Word.Application
    Set wdDoc = wdApp.Documents.Add
    ' 计算需要的行数：向上取整总人数/3
    rowNum = WorksheetFunction.RoundUp(totalCount / 3, 0)
    Set wdTable = wdDoc.Tables.Add(Range:=wdDoc.Range, NumRows:=rowNum, NumColumns:=3)
    
    ' 第四步：填充表格内容
    currentIdx = 0
    For r = 1 To rowNum
        For c = 1 To 3
            If currentIdx < totalCount Then
                wdTable.Cell(r, c).Range.Text = nameArr(currentIdx)
                currentIdx = currentIdx + 1
            Else
                wdTable.Cell(r, c).Range.Text = "" ' 多余单元格留空
            End If
        Next c
    Next r
    
    ' 显示Word文档
    wdApp.Visible = True
End Sub

' 辅助排序子程序：按sortArr的顺序同步排序两个数组
Sub SortTwoArrays(arr1 As Variant, arr2 As Variant)
    Dim i As Long, j As Long, temp1 As String, temp2 As String
    For i = LBound(arr1) To UBound(arr1) - 1
        For j = i + 1 To UBound(arr1)
            If arr1(i) > arr1(j) Then
                ' 交换排序数组元素
                temp1 = arr1(i)
                arr1(i) = arr1(j)
                arr1(j) = temp1
                ' 同步交换展示数组元素
                temp2 = arr2(i)
                arr2(i) = arr2(j)
                arr2(j) = temp2
            End If
        Next j
    Next i
End Sub

注意事项 #

• 使用前请确保Excel VBA引用中已经勾选「Microsoft Word xx.x Object Library」，操作路径：VBA编辑器→工具→引用，找到对应Word对象库勾选即可
• 代码默认姓名格式为「名 姓」以空格分隔，如果你的姓名格式有其他拆分规则，调整Split对应的拆分逻辑即可

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