不规则Excel数据拆分：VBA循环逻辑错误致重复复制求助

背景与需求 #

我从会计部门拿到POS系统自动生成的Excel表，里面客户数据和收据数据混在一起，有数千行，格式固定：

• 首列带日期的是客户记录行
• 客户行之后，A、B列都为空的行是收据数据行

需要实现：

• 把所有收据行复制到「Purchases」工作表，同时从原表删除这些行
• 给每一行收据数据补上对应客户行的收据编号（E列值）和推荐码（第13列值）

当前代码能识别收据行，但循环逻辑错误，导致收据记录被多次重复复制。

原错误代码 #

Public Sub MovePurchases()

Dim iRow As Integer
Dim iCol As Integer
Dim x As Integer
Dim LR As Long
Dim nLR As Long
Dim arrCount As Integer
Dim arrLBound As Integer
Dim arrUBound As Integer
Dim numRowsBlank As Integer
Dim rowLoopInt As Integer
Dim rcptNumber As Integer
Dim xOffset As Integer
Dim refCode As String

Dim nws As Worksheet
Dim ows As Worksheet

Set nws = Sheets("Purchases")
Set ows = ActiveSheet
' Find row count and set it as the upper boundary
LR = ows.UsedRange.Rows(ows.UsedRange.Rows.Count).Row

For x = 1 To LR
' Since we are detecting blank values in the CURRENT row, we must subtract
' 1 to get the value of the receipt number which is always in the precedeing row
    xOffset = x - 1
    If IsNumeric(Range("E" & x).Value) = True Then
    rcptNumber = ows.Cells(x, 5).Value
    refCode = ows.Cells(x, 13).Value
    End If
    If IsEmpty(Cells(x, 1).Value) = True And IsEmpty(Cells(x, 2).Value) = True Then
    'We know that the row is a receipt record.
    'Count the number of rows until the next blank a and b column
    numRowsBlank = Range("A1").End(xlDown).Row
    For rowLoopInt = 1 To numRowsBlank
        Range("A" & x).Value = rcptNumber
        Application.EnableEvents = False
    nLR = nws.Cells(Rows.Count, "A").End(xlUp).Row + 1
    ows.Rows(x).Copy nws.Cells(nLR, "A")
    Application.EnableEvents = True
        Next rowLoopInt
    
    End If

Next x

End Sub

错误原因 #

1. 多余的嵌套循环：For rowLoopInt = 1 To numRowsBlank完全没必要，会把当前收据行重复复制numRowsBlank次，这是重复记录的直接原因。
2. 错误的行数计算：numRowsBlank = Range("A1").End(xlDown).Row取的是A列从第一行到最后非空行的行号，和当前处理的收据行范围无关。
3. 未处理行删除的偏移问题：原代码没删除行，就算要删，从前往后循环删除行后，后续行号会偏移，导致漏处理。
4. 单元格引用未指定工作表：部分Range/Cells调用没指定ows，可能引发跨工作表的错误。

修正后的代码 #

Public Sub MovePurchases()
    Dim x As Long
    Dim LR As Long
    Dim nLR As Long
    Dim rcptNumber As Variant
    Dim refCode As String
    Dim nws As Worksheet
    Dim ows As Worksheet
    
    ' 禁用屏幕刷新和事件，提升效率
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Set nws = ThisWorkbook.Sheets("Purchases")
    Set ows = ActiveSheet
    LR = ows.Cells(ows.Rows.Count, "A").End(xlUp).Row
    
    ' 从后往前循环，避免删除行导致的行号偏移问题
    x = LR
    Do While x >= 1
        ' 识别客户记录行（首列有日期，用IsDate判断更准确）
        If IsDate(ows.Cells(x, "A").Value) Then
            rcptNumber = ows.Cells(x, "E").Value
            refCode = ows.Cells(x, "M").Value ' 第13列是M列
        ' 识别收据数据行（A、B列都为空）
        ElseIf IsEmpty(ows.Cells(x, "A").Value) And IsEmpty(ows.Cells(x, "B").Value) Then
            ' 给收据行补上收据编号和推荐码
            ows.Cells(x, "A").Value = rcptNumber
            ows.Cells(x, "B").Value = refCode ' 可根据需求调整列位置
            
            ' 复制到Purchases表
            nLR = nws.Cells(nws.Rows.Count, "A").End(xlUp).Row + 1
            ows.Rows(x).Copy Destination:=nws.Cells(nLR, "A")
            
            ' 从原表删除该行
            ows.Rows(x).Delete
        End If
        x = x - 1
    Loop
    
    ' 恢复设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

修正说明 #

1. 从后往前循环：处理行删除时，避免因删除行导致后续行号偏移，确保每一行都能被正确处理。
2. 准确识别客户行：用IsDate判断首列是否为日期，比原代码的IsNumeric更符合业务规则。
3. 移除多余嵌套循环：直接处理单条收据行，避免重复复制。
4. 统一工作表引用：所有单元格操作都指定了ows或nws，避免歧义。
5. 添加效率优化：禁用屏幕刷新和事件，提升数千行数据的处理速度。

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