Excel中如何按分隔符将多列单元格内容拆分到行且无重叠

功能说明 #

• 支持手动选择多列作为拆分目标列
• 按; 作为分隔符拆分单元格内容，自动生成新行
• 非目标列的内容会完整复制到所有拆分生成的新行
• 拆分后所有目标列的每行仅保留单个值，无多值重叠问题

使用步骤 #

1. 打开目标Excel工作簿，按下Alt+F11唤出VBA编辑器
2. 在左侧工程列表右键点击当前工作簿，选择「插入」-「模块」
3. 将下方代码粘贴到模块编辑区
4. 回到Excel表格界面，按住Ctrl选中所有需要拆分的列（支持选中不连续列）
5. 按下Alt+F8，选择splitMultiColumns宏，点击执行即可

完整代码 #

Sub splitMultiColumns()
    Dim selectRng As Range, r As Long, maxSplit As Long
    Dim i As Long, j As Long, splitArr As Variant, tempArr As Variant
    Dim delimiter As String: delimiter = "; " ' 可根据需要修改分隔符
    
    ' 获取用户选中的区域
    On Error Resume Next
    Set selectRng = Application.Selection
    If selectRng Is Nothing Then
        MsgBox "请先选择需要拆分的列", vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    
    ' 关闭屏幕更新提升运行速度
    Application.ScreenUpdating = False
    
    ' 从最后一行往上处理，避免插入行影响遍历顺序
    For r = selectRng.Rows.CountLarge To 1 Step -1
        maxSplit = 1
        ' 先计算当前行所有选中列的最大拆分数量
        ReDim tempArr(1 To selectRng.Columns.Count)
        For j = 1 To selectRng.Columns.Count
            splitArr = Split(selectRng.Cells(r, j).Value, delimiter)
            tempArr(j) = splitArr
            If UBound(splitArr) + 1 > maxSplit Then
                maxSplit = UBound(splitArr) + 1
            End If
        Next j
        
        ' 需要拆分的场景
        If maxSplit > 1 Then
            ' 插入对应数量的新行
            selectRng.Cells(r, 1).Offset(1).Resize(maxSplit - 1).EntireRow.Insert
            ' 填充拆分后的值
            For j = 1 To selectRng.Columns.Count
                For i = 0 To UBound(tempArr(j))
                    selectRng.Cells(r + i, j).Value = tempArr(j)(i)
                Next i
                ' 不足最大拆分数量的位置默认留空，可根据需求调整为填充上一个值
            Next j
        End If
    Next r
    
    Application.ScreenUpdating = True
    MsgBox "拆分完成！", vbInformation
End Sub

自定义调整说明 #

• 如果需要修改分隔符，只需修改代码中delimiter = "; "的引号内内容即可
• 如果需要拆分后按笛卡尔积生成全组合行，可自行调整拆分后值的填充逻辑

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