求助：将Excel多行单元格内容拆分至独立行（含VBA需求）

需求说明 #

Sheet1中每行包含唯一计算机名（A列）和多组文件详情（B列，每组含Path、Used by services、File write allowed for groups三项，组间以空行分隔），需要将每组文件详情与对应计算机名一一对应拆分到Sheet2的独立行，支持透视分析单个文件计数。

VBA解决方案 #

以下代码可直接实现拆分逻辑，避免循环重复问题：

Sub SplitFileDetails()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim lastRow As Long, targetRow As Long
    Dim fileDetails As Variant, singleDetail As Variant
    Dim i As Long
    
    ' 定义源表和目标表
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Set wsTarget = ThisWorkbook.Sheets("Sheet2")
    
    ' 清空目标表已有数据（保留表头）
    wsTarget.Range("A2:B" & wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row).ClearContents
    targetRow = 2 ' 从第2行开始写入（假设第1行是表头）
    
    ' 获取源表最后一行
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历源表每行数据
    For i = 2 To lastRow ' 假设第1行是表头
        ' 将B列内容按空行（两个换行符）分割为数组
        fileDetails = Split(wsSource.Cells(i, "B").Value, vbNewLine & vbNewLine)
        
        ' 遍历每组文件详情
        For Each singleDetail In fileDetails
            ' 过滤空内容（避免开头/结尾空行导致的空元素）
            If Trim(singleDetail) <> "" Then
                ' 写入计算机名
                wsTarget.Cells(targetRow, "A").Value = wsSource.Cells(i, "A").Value
                ' 写入单组文件详情
                wsTarget.Cells(targetRow, "B").Value = Trim(singleDetail)
                targetRow = targetRow + 1
            End If
        Next singleDetail
    Next i
    
    ' 自动调整目标表列宽
    wsTarget.Columns("A:B").AutoFit
    MsgBox "拆分完成！", vbInformation
End Sub

代码说明 #

1. 工作表定义：直接引用Sheet1和Sheet2，避免使用Activate/Select，提升运行效率
2. 空行分割：用vbNewLine & vbNewLine识别组间空行，将多组详情拆分为数组
3. 空内容过滤：通过Trim(singleDetail) <> ""排除分割后产生的空元素
4. 逐行写入：遍历每组详情，将对应计算机名和详情写入目标表的独立行
5. 收尾处理：自动调整列宽并提示完成

可选：拆分至单独列 #

如果需要将每组详情的三项拆分到C、D、E列，可替换写入部分的代码为：

' 拆分单组详情为三项
Dim detailParts As Variant
detailParts = Split(Trim(singleDetail), vbNewLine)
wsTarget.Cells(targetRow, "A").Value = wsSource.Cells(i, "A").Value
' 写入Path
wsTarget.Cells(targetRow, "C").Value = Replace(detailParts(0), "Path : ", "")
' 写入Used by services
wsTarget.Cells(targetRow, "D").Value = Replace(detailParts(1), "Used by services : ", "")
' 写入File write allowed for groups
wsTarget.Cells(targetRow, "E").Value = Replace(detailParts(2), "File write allowed for groups : ", "")
targetRow = targetRow + 1

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