满足条件时自动跨工作表传输数据的VBA问题求助

问题根源 #

你的代码逻辑存在两个关键问题：

1. 只要G列某单元格值为"Yes"，就会复制从该单元格向左偏移6列（A列）开始的25行×24列整块区域——这会把该区域内所有行（包括Status不为"Yes"的行）都一并复制，导致最终输出所有数据。
2. 粘贴位置的判断放在循环内部，每次循环都会重新计算粘贴起始点，可能会覆盖已复制的数据。

修正方案 #

根据你的实际需求选择对应方案：

方案1：仅复制Status为"Yes"的单行数据 #

如果需求是每一行G列值为"Yes"时，复制该行的A到X列（24列）数据，使用以下代码：

Sub CopyPoe()
    Dim StatusCol As Range
    Dim Status As Range
    Dim PasteCell As Range

    Set StatusCol = Tabelle2.Range("G2:G260")
    
    ' 初始化粘贴起始位置，避免循环内重复判断
    If Tabelle15.Range("A2") = "" Then
        Set PasteCell = Tabelle15.Range("A2")
    Else
        Set PasteCell = Tabelle15.Range("A1").End(xlDown).Offset(1, 0)
    End If

    For Each Status In StatusCol
        If Status.Value = "Yes" Then
            ' 复制当前Yes行的A到X列（24列）
            Status.Offset(0, -6).Resize(1, 24).Copy PasteCell
            ' 更新下一个粘贴位置
            Set PasteCell = PasteCell.Offset(1, 0)
        End If
    Next Status
End Sub

方案2：复制Yes行起始的25行中符合条件的行 #

如果需求是当某行G列为"Yes"时，复制从该行开始的25行里所有Status为"Yes"的行，使用以下代码：

Sub CopyPoe()
    Dim StatusCol As Range
    Dim Status As Range
    Dim PasteCell As Range
    Dim i As Integer

    Set StatusCol = Tabelle2.Range("G2:G260")
    
    ' 初始化粘贴起始位置
    If Tabelle15.Range("A2") = "" Then
        Set PasteCell = Tabelle15.Range("A2")
    Else
        Set PasteCell = Tabelle15.Range("A1").End(xlDown).Offset(1, 0)
    End If

    For Each Status In StatusCol
        If Status.Value = "Yes" Then
            ' 遍历当前行开始的25行，仅复制Status为Yes的行
            For i = 0 To 24
                If Status.Offset(i, 0).Value = "Yes" Then
                    Status.Offset(i, -6).Resize(1, 24).Copy PasteCell
                    Set PasteCell = PasteCell.Offset(1, 0)
                End If
            Next i
        End If
    Next Status
End Sub

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