如何用Excel VBA将E列非0的所有行复制到另一工作表？

两段代码的核心问题是：lrowdat仅在循环开始前被赋值一次，每次找到符合条件的行时，都会把数据写入同一个行号，后续内容会覆盖之前的，最终只保留最后一条符合条件的记录。

版本1（原alt1修改） #

在每次写入符合条件的数据后，将lrowdat加1，确保下一条数据写入新行：

Sub alt1()
    Dim wsfrom As Worksheet
    Dim wsData As Worksheet
    
    Set wsfrom = Sheets("Alt")
    Set wsData = Sheets("Dat")
    
    Dim lrowdat As Long
    Dim lrowfrom As Long
    Dim i As Long ' 显式声明循环变量，避免隐式类型
    
    lrowdat = ThisWorkbook.Sheets("Dat").Cells(Rows.Count, 1).End(xlUp).Row + 1
    lrowfrom = ThisWorkbook.Sheets("Alt").Range("A" & Rows.Count).End(xlUp).Row
    
    For i = 10 To lrowfrom
        If wsfrom.Range("E" & i) <> 0 Then
            wsData.Range("A" & lrowdat).Value = wsfrom.Range("A" & i).Value
            wsData.Range("D" & lrowdat).Value = wsfrom.Range("D" & i).Value
            wsData.Range("E" & lrowdat).Value = wsfrom.Range("E" & i).Value
            lrowdat = lrowdat + 1 ' 关键：每次写入后行号自增
        End If
    Next i
    
End Sub

版本2（原alt2修改） #

同样在粘贴后递增lrowdat，同时关闭屏幕刷新提升运行效率：

Sub alt2()
    Dim wsfrom As Worksheet
    Dim wsData As Worksheet
    
    Set wsfrom = Sheets("Alt")
    Set wsData = Sheets("Dat")
    
    Dim lrowdat As Long
    Dim lrowfrom As Long
    Dim i As Long ' 显式声明循环变量
    
    Application.ScreenUpdating = False ' 关闭屏幕刷新，加快运行速度
    lrowdat = ThisWorkbook.Sheets("Dat").Cells(Rows.Count, 1).End(xlUp).Row + 1
    lrowfrom = ThisWorkbook.Sheets("Alt").Range("A" & Rows.Count).End(xlUp).Row
    
    For i = 10 To lrowfrom
        If wsfrom.Range("E" & i) <> 0 Then
            wsfrom.Range("A" & i).EntireRow.Copy
            wsData.Range("A" & lrowdat).PasteSpecial Paste:=xlPasteValues
            lrowdat = lrowdat + 1 ' 关键：每次粘贴后行号自增
        End If
    Next i
    
    Application.CutCopyMode = False ' 清除复制模式
    Application.ScreenUpdating = True ' 恢复屏幕刷新
End Sub

如果数据量较大，逐行循环效率偏低，可以用筛选功能批量复制符合条件的行：

Sub CopyFilteredRows()
    Dim wsFrom As Worksheet, wsDat As Worksheet
    Dim lastRow As Long, targetRow As Long
    
    Set wsFrom = Sheets("Alt")
    Set wsDat = Sheets("Dat")
    
    targetRow = wsDat.Cells(Rows.Count, 1).End(xlUp).Row + 1
    lastRow = wsFrom.Cells(Rows.Count, "E").End(xlUp).Row
    
    ' 筛选E列不为0的行
    wsFrom.Range("E9:E" & lastRow).AutoFilter Field:=1, Criteria1:="<>" & 0
    
    ' 复制筛选后的可见行（从第10行开始）
    wsFrom.Range("A10:E" & lastRow).SpecialCells(xlCellTypeVisible).Copy
    wsDat.Range("A" & targetRow).PasteSpecial xlPasteValues
    
    ' 取消筛选
    wsFrom.AutoFilterMode = False
    Application.CutCopyMode = False
End Sub

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