Excel VBA技术需求：按单元格值提取行并粘贴为值至其他工作表

我需要从DATA工作表中提取S列值为YES的整行数据，然后仅以值的形式粘贴到Boven_500工作表，同时删除原数据行。以下是我找到的代码，但它无法实现仅粘贴值的需求，还存在逻辑问题：

Sub Rubbisch()
        Dim xRg As Range
        Dim xCell As Range
        Dim i As Long
        Dim J As Long
        Dim K As Long
        i = Worksheets("DATA").UsedRange.Rows.Count
        J = Worksheets("uitzonderingen").UsedRange.Rows.Count
        If J = 1 Then
           If Application.WorksheetFunction.CountA(Worksheets("Boven_500").UsedRange) = 0 Then J = 0
        End If
        Set xRg = Worksheets("DATA").Range("S1:S" & i)
        On Error Resume Next
        Application.ScreenUpdating = False
        For K = 1 To xRg.Count
            If CStr(xRg(K).Value) = "YES" Then
                xRg(K).EntireRow.Copy Destination:=Worksheets("Boven_500").Range("A" & J + 1)
                
                xRg(K).EntireRow.Delete
                If CStr(xRg(K).Value) = "YES" Then
                    K = K - 1
                End If
                J = J + 1
            End If
        Next
        Application.ScreenUpdating = True
        
            End Sub

现有代码的问题 #

• 用Copy直接粘贴会附带格式、公式，不符合“仅粘贴值”的要求
• 正向遍历删除行，会导致索引错位，部分符合条件的行可能被跳过
• 错误使用uitzonderingen工作表的行数计算目标起始行，逻辑混乱

修正后的代码 #

Sub ExtractAndPasteValues()
    Dim dataWs As Worksheet, targetWs As Worksheet
    Dim lastDataRow As Long, targetLastRow As Long
    Dim i As Long
    
    ' 指定工作表对象
    Set dataWs = ThisWorkbook.Worksheets("DATA")
    Set targetWs = ThisWorkbook.Worksheets("Boven_500")
    
    Application.ScreenUpdating = False
    
    ' 获取DATA表S列最后一行的行号
    lastDataRow = dataWs.Cells(dataWs.Rows.Count, "S").End(xlUp).Row
    
    ' 从最后一行往上遍历，避免删除行导致的索引错误
    For i = lastDataRow To 1 Step -1
        If CStr(dataWs.Cells(i, "S").Value) = "YES" Then
            ' 确定目标表的粘贴起始行
            targetLastRow = targetWs.Cells(targetWs.Rows.Count, "A").End(xlUp).Row
            If targetLastRow = 1 And targetWs.Cells(1, "A").Value = "" Then
                targetLastRow = 0 ' 目标表为空时从第1行开始粘贴
            End If
            
            ' 仅复制值到目标表
            dataWs.Rows(i).Copy
            targetWs.Range("A" & targetLastRow + 1).PasteSpecial Paste:=xlPasteValues
            
            ' 删除原数据行
            dataWs.Rows(i).Delete
        End If
    Next i
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

关键改进点 #

• 仅粘贴值：通过PasteSpecial xlPasteValues实现只复制单元格内容，排除格式、公式等冗余信息
• 反向遍历：从最后一行开始往上循环，删除行后不会影响未处理的行索引，确保所有符合条件的行都被处理
• 正确计算目标起始行：直接基于Boven_500工作表的实际内容判断起始位置，逻辑更准确
• 代码可读性：使用明确的变量名和工作表对象，便于后续维护

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