如何用VBA将Excel多员工宽列转换为单员工窄列

你的现有代码是将员工姓名横向拆分到当前行的后续列中，要实现每行仅含一名员工的窄表格式，需要改为纵向新增行并对应复制所属部门，以下是可行的VBA代码：

Sub ConvertToNarrowTable()
    Dim ws As Worksheet
    Dim sourceLastRow As Long, outputRow As Long
    Dim i As Long, j As Long
    Dim empArr() As String
    
    ' 指定处理的工作表，可替换为具体表名如Sheets("Sheet1")
    Set ws = ActiveSheet
    
    ' 获取部门列（A列）的最后数据行
    sourceLastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 初始化输出起始行：若保留原表头，从第2行开始；若新建表则先写表头再从第2行开始
    outputRow = 2
    
    ' 遍历每一行源数据（跳过第1行表头）
    For i = 2 To sourceLastRow
        ' 按空格拆分员工列（B列）的内容
        empArr = Split(ws.Cells(i, "B").Value, " ")
        
        ' 遍历每个拆分后的员工姓名
        For j = LBound(empArr) To UBound(empArr)
            ' 过滤空字符串（处理连续空格的情况）
            If Trim(empArr(j)) <> "" Then
                ' 写入对应部门
                ws.Cells(outputRow, "A").Value = ws.Cells(i, "A").Value
                ' 写入员工姓名（去除首尾空格）
                ws.Cells(outputRow, "B").Value = Trim(empArr(j))
                ' 输出行号递增
                outputRow = outputRow + 1
            End If
        Next j
    Next i
    
    ' 可选：若在原表操作，完成后可删除原始数据行（保留表头）
    ' ws.Rows("2:" & sourceLastRow).Delete
End Sub

关键改动说明 #

1. 纵向输出逻辑：不再横向填充列，而是逐行新增记录，每个员工对应一行，同时复制所属部门
2. 空值过滤：加入Trim判断，避免因连续空格拆分出空字符串导致无效行
3. 灵活输出位置：可选择在原工作表操作（完成后可删除原始行），或新建工作表存放结果（代码中已给出注释示例）

如果需要保留原始数据，建议使用新建工作表的方式，只需取消代码中新建工作表的注释，并调整输出起始行即可。

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