Offset VBA问题：将List工作表数据分配至多个上传工作表

错误原因 #

你的代码出现数据翻倍/三倍增长的核心问题是：CopyRange变量在处理完第一个工作表后没有被重置为Nothing。

第一次循环处理完First Upload后，CopyRange已经存储了所有要复制到该表的行；后续处理Second Upload时，代码直接在这个已有范围的基础上执行Union操作，把当前循环选中的行和之前的行合并，最终导致Second Upload的数据是First+Second的行，以此类推，后续工作表的数据量自然越来越大。

另外，原代码没有明确指定源工作表（Sheets("List")），如果当前激活的不是List表，会导致读取错误的行数据。

修正方案1：修复原代码逻辑 #

在每个工作表的处理块前，添加Set CopyRange = Nothing重置变量，同时明确指定源工作表：

Sub OffsetTrial_Fixed()
    
    Dim X As Long, LastRow As Long
    Dim CopyRange As Range
    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.Sheets("List") ' 指定源工作表
    
    ' 处理First Upload
    LastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    Set CopyRange = Nothing ' 重置范围变量
    For X = 2 To LastRow Step 5
        If CopyRange Is Nothing Then
            Set CopyRange = wsSource.Rows(X).EntireRow
        Else
            Set CopyRange = Union(CopyRange, wsSource.Rows(X).EntireRow)
        End If
    Next
    If Not CopyRange Is Nothing Then
        CopyRange.Copy Destination:=Sheets("First Upload").Range("A2")
    End If
    
    ' 处理Second Upload
    LastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    Set CopyRange = Nothing ' 重置范围变量
    For X = 3 To LastRow Step 5
        If CopyRange Is Nothing Then
            Set CopyRange = wsSource.Rows(X).EntireRow
        Else
            Set CopyRange = Union(CopyRange, wsSource.Rows(X).EntireRow)
        End If
    Next
    If Not CopyRange Is Nothing Then
        CopyRange.Copy Destination:=Sheets("Second Upload").Range("A2")
    End If
    
    ' 处理Third Upload
    LastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    Set CopyRange = Nothing ' 重置范围变量
    For X = 4 To LastRow Step 5
        If CopyRange Is Nothing Then
            Set CopyRange = wsSource.Rows(X).EntireRow
        Else
            Set CopyRange = Union(CopyRange, wsSource.Rows(X).EntireRow)
        End If
    Next
    If Not CopyRange Is Nothing Then
        CopyRange.Copy Destination:=Sheets("Third Upload").Range("A2")
    End If
    
    ' 处理Fourth Upload
    LastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    Set CopyRange = Nothing ' 重置范围变量
    For X = 5 To LastRow Step 5
        If CopyRange Is Nothing Then
            Set CopyRange = wsSource.Rows(X).EntireRow
        Else
            Set CopyRange = Union(CopyRange, wsSource.Rows(X).EntireRow)
        End If
    Next
    If Not CopyRange Is Nothing Then
        CopyRange.Copy Destination:=Sheets("Fourth Upload").Range("A2")
    End If
    
    ' 处理Fifth Upload
    LastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    Set CopyRange = Nothing ' 重置范围变量
    For X = 6 To LastRow Step 5
        If CopyRange Is Nothing Then
            Set CopyRange = wsSource.Rows(X).EntireRow
        Else
            Set CopyRange = Union(CopyRange, wsSource.Rows(X).EntireRow)
        End If
    Next
    If Not CopyRange Is Nothing Then
        CopyRange.Copy Destination:=Sheets("Fifth Upload").Range("A2")
    End If
    
End Sub

修正方案2：高效优化版（推荐） #

原代码重复了5次几乎相同的循环，且Union操作处理20000行数据效率较低。以下优化版本通过一次遍历完成分配，逻辑更清晰，执行效率更高：

Sub DistributeRows_Efficient()
    Dim wsSource As Worksheet
    Dim wsTargets(1 To 5) As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim targetIdx As Integer
    Dim targetRow(1 To 5) As Long
    
    ' 初始化源工作表和目标工作表
    Set wsSource = ThisWorkbook.Sheets("List")
    Set wsTargets(1) = ThisWorkbook.Sheets("First Upload")
    Set wsTargets(2) = ThisWorkbook.Sheets("Second Upload")
    Set wsTargets(3) = ThisWorkbook.Sheets("Third Upload")
    Set wsTargets(4) = ThisWorkbook.Sheets("Fourth Upload")
    Set wsTargets(5) = ThisWorkbook.Sheets("Fifth Upload")
    
    ' 清空目标工作表的旧数据（从第2行开始）
    For i = 1 To 5
        With wsTargets(i)
            If .Cells(.Rows.Count, "A").End(xlUp).Row >= 2 Then
                .Range("A2:" & .Cells(.Rows.Count, "A").End(xlUp).Address).ClearContents
            End If
            targetRow(i) = 2 ' 目标表的起始写入行
        End With
    Next i
    
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历源数据行（从第2行开始），分配到对应目标表
    For i = 2 To lastRow
        ' 计算当前行的目标表索引：第2行→1，第3→2，…，第6→5，第7→1，循环分配
        targetIdx = ((i - 2) Mod 5) + 1
        
        ' 复制当前行到目标表
        wsSource.Rows(i).Copy Destination:=wsTargets(targetIdx).Cells(targetRow(targetIdx), "A")
        targetRow(targetIdx) = targetRow(targetIdx) + 1
    Next i
End Sub

优化点说明 #

• 用数组管理目标工作表，避免重复代码
• 自动清空目标表旧数据，防止残留
• 一次遍历完成所有行的分配，无需Union操作，处理大量数据更高效
• 逻辑清晰，不易出现变量未重置的错误

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