如何在新工作表中转置桌号-人名表格并按指定规则排序？

问题说明 #

原数据位于工作表（默认假设为Sheet1）的A5起始区域，结构如下：

table_number   name
 1             cathy
 3             sarah
 1             bob
               jake     (无桌号，需忽略)

需要在新工作表（比如Sheet2）生成按桌号升序排列、同桌号人名字母排序的结果，保留重复人名，忽略无桌号记录，预期效果：

1        2        3
bob      ...     sarah
cathy

公式实现（Excel 365/2021 推荐） #

1. 生成排序后的桌号表头 #

在Sheet2的A1单元格输入公式，回车后会自动填充所有唯一桌号并升序排列：

=SORT(UNIQUE(FILTER(Sheet1!A5:A,Sheet1!A5:A<>"")))

2. 填充对应桌号的排序人名 #

在Sheet2的A2单元格输入以下公式，向右拖动到所有桌号列，再向下拖动填充足够行数：

=IFERROR(INDEX(SORT(FILTER(Sheet1!B$5:B,Sheet1!A$5:A=A$1)),ROW(A1)),"")

如果需要把空单元格显示为...，可以把公式改成：

=IFERROR(INDEX(SORT(FILTER(Sheet1!B$5:B,Sheet1!A$5:A=A$1)),ROW(A1)),"...")

VBA宏实现（适合旧版Excel或批量处理） #

如果用的是旧版Excel，或者需要一键自动化处理，可以用以下宏代码：

Sub ConvertTable()
    Dim srcWS As Worksheet, destWS As Worksheet
    Dim srcData As Variant, uniqueTables As Variant
    Dim tableDict As Object
    Dim i As Long, j As Long, maxRows As Long
    
    ' 替换成你的源表和目标表名称
    Set srcWS = ThisWorkbook.Sheets("Sheet1")
    Set destWS = ThisWorkbook.Sheets("Sheet2")
    destWS.Cells.Clear ' 清空目标表旧数据
    
    ' 读取源数据范围
    srcData = srcWS.Range("A5:B" & srcWS.Cells(srcWS.Rows.Count, "A").End(xlUp).Row).Value
    
    ' 用字典存每个桌号对应的人名列表
    Set tableDict = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(srcData)
        If srcData(i, 1) <> "" Then ' 跳过无桌号的记录
            If Not tableDict.Exists(srcData(i, 1)) Then
                tableDict(srcData(i, 1)) = New Collection
            End If
            tableDict(srcData(i, 1)).Add srcData(i, 2)
        End If
    Next i
    
    ' 对桌号升序排序
    uniqueTables = GetSortedKeys(tableDict)
    
    ' 写入桌号表头
    For j = 1 To UBound(uniqueTables)
        destWS.Cells(1, j).Value = uniqueTables(j)
    Next j
    
    ' 写入排序后的人名
    maxRows = 0
    For j = 1 To UBound(uniqueTables)
        ' 提取当前桌号的人名并排序
        Dim nameList() As String
        ReDim nameList(1 To tableDict(uniqueTables(j)).Count)
        For i = 1 To tableDict(uniqueTables(j)).Count
            nameList(i) = tableDict(uniqueTables(j))(i)
        Next i
        SortArray nameList
        
        ' 写入目标表
        destWS.Cells(2, j).Resize(UBound(nameList)).Value = Application.Transpose(nameList)
        If UBound(nameList) > maxRows Then maxRows = UBound(nameList)
    Next j
    
    ' 空单元格填充"..."（不需要可删除此行）
    destWS.Range("A2:" & destWS.Cells(maxRows + 1, UBound(uniqueTables)).Address).SpecialCells(xlCellTypeBlanks).Value = "..."
End Sub

' 辅助函数：排序字典的桌号键
Function GetSortedKeys(dict As Object) As Variant
    Dim keys() As String, i As Long, j As Long, temp As String
    ReDim keys(1 To dict.Count)
    
    i = 1
    For Each key In dict.Keys
        keys(i) = key
        i = i + 1
    Next key
    
    ' 升序排序桌号
    For i = 1 To UBound(keys)
        For j = i + 1 To UBound(keys)
            If CLng(keys(i)) > CLng(keys(j)) Then
                temp = keys(i)
                keys(i) = keys(j)
                keys(j) = temp
            End If
        Next j
    Next i
    
    GetSortedKeys = keys
End Function

' 辅助函数：对人名数组按字母排序
Sub SortArray(arr() As String)
    Dim i As Long, j As Long, temp As String
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If UCase(arr(i)) > UCase(arr(j)) Then
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
            End If
        Next j
    Next i
End Sub

使用步骤： #

1. 按Alt+F11打开VBA编辑器
2. 右键插入「模块」，粘贴上述代码
3. 修改代码里的Sheet1和Sheet2为你实际的工作表名称
4. 运行ConvertTable宏即可完成转换

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