Excel VBA：拆分多行多列单元格时日期/传输方式列处理异常求助

现有一表格需拆分每行，使每行每个单元格仅包含一个姓名/日期/传输方式。已成功实现姓名列拆分，但处理日期和传输方式列时遇问题——部分对应列单元格为空，复用拆分姓名的逻辑编写代码后运行异常，本该为空的单元格被错误填充。

已实现的姓名列拆分VBA代码 #

Sub splitcells()

Dim splitVals As Variant

Dim totalVals As Long

Set sh1 = ThisWorkbook.Sheets(1)

Set sh2 = ThisWorkbook.Sheets(2)

lrow1 = sh1.Range("A65356").End(xlUp).Row

For j = 2 To lrow1

splitVals = split(sh1.Cells(j, 2), Chr(10))

For i = LBound(splitVals) To UBound(splitVals)

lrow2 = sh2.Range("B65356").End(xlUp).Row

lrow3 = sh2.Range("A65356").End(xlUp).Row

sh2.Cells(lrow3 + 1, 1) = sh1.Cells(j, 1)

sh2.Cells(lrow3 + 1, 2) = splitVals(i)

Next i

Next j

End Sub

日期列拆分的错误代码 #

尝试复用上述逻辑处理日期列，编写了如下代码，但运行后会错误填充所有单元格（本该为空的单元格也被填充）：

Sub splitcells2()

Dim splitVals As Variant

Dim totalVals As Long

Set sh1 = ThisWorkbook.Sheets(1)

Set sh3 = ThisWorkbook.Sheets(3)

lrow1 = sh1.Range("A65356").End(xlUp).Row

For j = 2 To lrow1

splitVals = split(sh1.Cells(j, 3), Chr(10))

For i = LBound(splitVals) To UBound(splitVals)

lrow2 = sh3.Range("B65356").End(xlUp).Row

lrow3 = sh3.Range("A65356").End(xlUp).Row

sh3.Cells(lrow3 + 1, 1) = sh1.Cells(j, 1)

sh3.Cells(lrow3 + 1, 2) = splitVals(i)

Next i

Next j

End Sub

输入与期望结果说明 #

• 输入表格：序号列是唯一标识，姓名列存在多个用换行分隔的姓名，日期列、传输方式列部分单元格为空，部分有多个换行分隔的内容
• 期望结果：拆分后每行对应一个序号、一个姓名、一个日期（无则为空）、一种传输方式（无则为空），保持原行中姓名、日期、传输方式的对应关系

解决方案 #

问题根源：当单元格为空时，Split函数会返回包含空字符串的数组，导致循环依然执行填充空内容；且分开处理不同列无法保持数据关联关系。以下是整合后的代码，直接生成符合要求的结果到新工作表：

Sub SplitAllColumns()
    Dim wsSource As Worksheet, wsDest As Worksheet
    Dim lastRow As Long, destRow As Long
    Dim nameArr As Variant, dateArr As Variant, methodArr As Variant
    Dim maxItems As Integer, j As Integer, i As Integer
    
    ' 设置源工作表和目标工作表
    Set wsSource = ThisWorkbook.Sheets(1)
    Set wsDest = ThisWorkbook.Sheets.Add(After:=wsSource)
    wsDest.Name = "拆分结果"
    
    ' 写入表头（根据实际表头调整）
    wsDest.Range("A1:D1") = Array("序号", "姓名", "日期", "传输方式")
    
    lastRow = wsSource.Range("A" & wsSource.Rows.Count).End(xlUp).Row
    destRow = 2 ' 从第二行开始写入数据
    
    ' 遍历源数据行
    For j = 2 To lastRow
        ' 拆分各列数据，空单元格返回空数组避免无效循环
        nameArr = Split(IIf(wsSource.Cells(j, 2) = "", vbNullString, wsSource.Cells(j, 2)), Chr(10))
        dateArr = Split(IIf(wsSource.Cells(j, 3) = "", vbNullString, wsSource.Cells(j, 3)), Chr(10))
        methodArr = Split(IIf(wsSource.Cells(j, 4) = "", vbNullString, wsSource.Cells(j, 4)), Chr(10))
        
        ' 获取当前行最多的条目数，确保所有内容都能拆分
        maxItems = Application.Max(UBound(nameArr) + 1, UBound(dateArr) + 1, UBound(methodArr) + 1)
        
        ' 写入拆分后的数据，无对应内容则留空
        For i = 0 To maxItems - 1
            wsDest.Cells(destRow, 1) = wsSource.Cells(j, 1)
            wsDest.Cells(destRow, 2) = IIf(i <= UBound(nameArr), nameArr(i), "")
            wsDest.Cells(destRow, 3) = IIf(i <= UBound(dateArr), dateArr(i), "")
            wsDest.Cells(destRow, 4) = IIf(i <= UBound(methodArr), methodArr(i), "")
            destRow = destRow + 1
        Next i
    Next j
End Sub

代码关键点 #

1. 空单元格处理：用IIf判断单元格是否为空，为空则传入vbNullString，Split后得到空数组，避免无效循环填充空内容
2. 数据关联保持：一次性处理每行的三个列，根据当前行最多条目数循环，确保姓名、日期、传输方式一一对应
3. 结果整合：直接生成到新工作表，无需分多个工作表处理，符合期望格式

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