我建议添加一个for循环和一个条件：

• for循环迭代范围，即OneRng检查列P中的标志
• 粘贴前检查目标单元格的值是否符合要求的条件，即“是！”。然后将每行（不包括P列）复制到工作表B

请验证并让我知道此解决方案是否适用。下面是更新的代码片段：

Sub copy_sheetA_to_sheetB()

  Dim OneRng As Range
  Set OneRng = Sheets("Sheet A").Range("P2:AA" & Cells(Rows.Count, "A").End(xlUp).Row) 'include column P as a flag
  For c = 1 To OneRng.Rows.Count
  If OneRng.Cells(c,1).Value  = "Yes!" Then
      OneRng.Offset(0,1).Resize(OneRng.Rows.Count, OneRng.Columns.Count-1).copy
      Sheets("Sheet B").Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
  End If
  
  Application.CutCopyMode = False

End Sub

复制条件值

第一节第一节第一节第一节第一次

Sub CopyAtoB()
    
    ' Define constants.
    
    Const SRC_SHEET As String = "Sheet A"
    Const SRC_FIRST_LOOKUP_CELL As String = "P2"
    Const SRC_COPY_COLUMNS As String = "Q:AA"
    Const DST_SHEET As String = "Sheet B"
    Const DST_FIRST_CELL As String = "A2"
    Const CRITERIA_STRING As String = "Yes!" ' case-insensitive
    
    ' Reference the workbook.
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source range.
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET)
    If sws.FilterMode Then sws.ShowAllData
    
    Dim slrg As Range, srCount As Long
    
    With sws.Range(SRC_FIRST_LOOKUP_CELL)
        Dim slCell As Range: Set slCell = .Resize(sws.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If Not slCell Is Nothing Then
            srCount = slCell.Row - .Row + 1
            Set slrg = .Resize(srCount)
        End If
    End With
    
    If srCount = 0 Then
        MsgBox "No data found.", vbExclamation
        Exit Sub
    End If
    
    Dim scrg As Range: Set scrg = slrg.EntireRow.Columns(SRC_COPY_COLUMNS)
    Dim cCount As Long: cCount = scrg.Columns.Count
    
    ' Write the values from the source range to the Data array.
    Dim Data(): Data = scrg.Value
    
    ' Return the matches in a 2D one-based single-column array
    ' of the same size as the size of the source lookup range.
    ' Matches will return 1 while non-matches will return an error value.
    
    Dim srMatches():
    srMatches = Application.Match(slrg, Array(CRITERIA_STRING), 0)
    
    If Application.Count(srMatches) = 0 Then
        MsgBox "No criteria matches found.", vbCritical
        Exit Sub
    End If
    
    ' Write the matching rows to the top of the Data array.
    
    Dim sr As Long, c As Long, dr As Long
    
    For sr = 1 To srCount
        If IsNumeric(srMatches(sr, 1)) Then
            dr = dr + 1
            For c = 1 To cCount
                Data(dr, c) = Data(sr, c)
            Next c
        End If
    Next sr
    
    ' Reference the destination range.
    
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET)
    If dws.FilterMode Then dws.ShowAllData
    
    Dim dfCell As Range
    
    With dws.Range(DST_FIRST_CELL)
        Set dfCell = .Resize(dws.Rows.Count - .Row + 1) _
           .Find("*", , xlFormulas, , , xlPrevious)
        If dfCell Is Nothing Then
            Set dfCell = .Cells
        Else
            Set dfCell = dfCell.Offset(1)
        End If
    End With
    
    Dim drg As Range: Set drg = dfCell.Resize(dr, cCount)
    
    ' Write the values from the top of the Data array to the destination range.
    
    drg.Value = Data

    ' Inform.

    MsgBox "Values copied.", vbInformation

End Sub