Excel VBA按分组粘贴数据到对应工作表A1起始位的代码优化问题

问题原因 #

原来的代码每次切换到A/B/C工作表时都会强制选中A1单元格，所以每次粘贴都会覆盖A1起始的内容，只有最后一次粘贴的行能保留。同时大量使用Activate、Select方法也容易受用户手动选中的单元格影响，导致逻辑异常。

优化后代码 #

Sub data_category()
    Dim y As Integer
    Dim x As String
    Dim sourceRow As Range
    Dim targetLastRow As Long
    Dim wsSource As Worksheet, wsTarget As Worksheet
    
    ' 提前绑定源工作表，避免反复切换激活
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    
    ' 遍历从A3开始的所有非空行
    For Each sourceRow In wsSource.Range("A3", wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp)).Rows
        y = sourceRow.Offset(0, 3).Value
        
        ' 判定分组
        If y < 90 Then
            x = "A"
        ElseIf y < 120 Then
            x = "B"
        Else
            x = "C"
        End If
        sourceRow.Offset(0, 4).Value = x
        
        ' 绑定目标工作表，找最后一行非空位置的下一行作为粘贴起始
        Set wsTarget = ThisWorkbook.Sheets(x)
        targetLastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row
        ' 处理目标表为空的情况，保证第一行从A1开始粘
        If targetLastRow = 1 And wsTarget.Range("A1").Value = "" Then
            targetLastRow = 0
        End If
        
        ' 直接复制行到目标位置，不需要选中/激活
        sourceRow.Resize(1, sourceRow.End(xlToRight).Column - sourceRow.Column + 1).Copy _
            Destination:=wsTarget.Range("A" & targetLastRow + 1)
    Next sourceRow
End Sub

核心优化点 #

• 取消所有Activate、Select操作，直接通过工作表对象操作数据，不受当前选中区域干扰
• 每次粘贴前先计算目标工作表A列最后一个非空行的位置，新数据自动追加到最后一行下方
• 增加空表判断，首次粘贴时从A1开始，后续自动顺延不会覆盖原有数据
• 改用For Each遍历行，逻辑更清晰，避免Do Loop判断空行可能出现的异常

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