VBA脚本运行时错误1004排查求助：拆分单元格复制行异常

问题根源 #

你的代码触发1004错误主要有两个原因：

• 工作表名称不匹配：需求是处理DATA工作表，但代码中指定的是Sheet1，若实际工作表为DATA，会直接导致对象引用无效
• 循环插入行后逐行复制的逻辑冗余，多次行操作容易触发Excel内部的操作冲突

另外原代码未处理单元格为空、拆分后出现空字符串的情况，可能引发后续逻辑异常。

修正后的代码 #

Sub CopyRowsAndFillSubstrings()
    Dim lastRow As Long
    Dim i As Long, j As Long, k As Long
    Dim substrCount As Long
    Dim substrArr() As String
    Dim targetSheet As Worksheet
    
    ' 绑定目标工作表（匹配需求的DATA表）
    Set targetSheet = ThisWorkbook.Worksheets("DATA")
    
    ' 获取初始数据最后一行（从下往上循环，初始值固定不受插入行影响）
    lastRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row
    
    ' 从末行往上遍历，避免插入行干扰未处理的行
    For i = lastRow To 1 Step -1
        substrArr = Split(Trim(targetSheet.Range("A" & i).Value), ";")
        substrCount = 0
        
        ' 统计有效子字符串数量（排除空值）
        For j = LBound(substrArr) To UBound(substrArr)
            If Trim(substrArr(j)) <> "" Then
                substrCount = substrCount + 1
            End If
        Next j
        
        If substrCount > 1 Then
            ' 一次性插入所需行数，减少行操作次数
            targetSheet.Rows(i + 1 & ":" & i + substrCount - 1).Insert Shift:=xlDown
            ' 批量复制原行到插入的所有行
            targetSheet.Rows(i).Copy Destination:=targetSheet.Rows(i + 1 & ":" & i + substrCount - 1)
            
            ' 填充每个行的A列为对应有效子字符串
            j = 0
            For k = LBound(substrArr) To UBound(substrArr)
                If Trim(substrArr(k)) <> "" Then
                    targetSheet.Cells(i + j, "A").Value = Trim(substrArr(k))
                    j = j + 1
                End If
            Next k
        End If
    Next i
End Sub

核心优化说明 #

1. 明确工作表引用：直接绑定DATA工作表，避免因ActiveSheet切换导致的引用错误
2. 批量操作行：一次性插入substrCount - 1行（原行已存在，只需复制n-1次），替代循环插入，降低Excel操作冲突概率
3. 过滤空字符串：添加有效子串统计逻辑，避免拆分后空值导致的无效行复制
4. 批量复制：一次性完成原行到所有插入行的复制，提升代码执行效率

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