Hey there! 我看你需要实现一个自动检查Worksheet 2并复制内容到Worksheet 1的功能，下面是完整的VBA代码，附带详细解释，你可以直接用或者根据自己的实际情况调整：

Sub CopyQualifiedCells()
    ' 定义工作表对象，避免后续操作混淆
    Dim sourceWs As Worksheet
    Dim targetWs As Worksheet
    ' 记录目标工作表的下一个粘贴行
    Dim nextTargetRow As Long
    ' 循环计数器
    Dim i As Long
    
    ' 绑定源工作表和目标工作表
    Set sourceWs = ThisWorkbook.Worksheets("Worksheet 2")
    Set targetWs = ThisWorkbook.Worksheets("Worksheet 1")
    
    ' 从Worksheet 1的B2开始粘贴
    nextTargetRow = 2
    
    ' 循环检查100组：从第10行开始，每10行一组（对应你说的"接下来的100行"的组逻辑）
    ' 如果是要连续检查100行（行10到行109），把循环改成 For i = 10 To 109
    For i = 10 To 10 + 99 * 10 Step 10
        ' 不区分大小写检查B列是否为"Yes"，避免大小写问题漏判
        If UCase(sourceWs.Cells(i, "B").Value) = "YES" Then
            ' 复制对应组的第4行B列内容（比如第10行对应第4行，第20行对应第14行，以此类推）
            targetWs.Cells(nextTargetRow, "B").Value = sourceWs.Cells(i - 6, "B").Value
            ' 粘贴完一行后，目标行下移
            nextTargetRow = nextTargetRow + 1
        End If
    Next i
    
    ' 弹出提示框告知完成情况
    MsgBox "操作完成！一共复制了 " & nextTargetRow - 2 & " 条符合条件的数据。", vbInformation
End Sub

关键逻辑说明 #

• 工作表绑定：先明确sourceWs和targetWs，防止在有多个工作表时选错操作对象。
• 不区分大小写判断：用UCase()把单元格内容转成大写，这样不管单元格里是Yes、YES还是yes都能正确识别。
• 高效赋值代替粘贴：直接用.Value赋值比复制粘贴更快，还不会占用剪贴板，避免干扰其他操作。
• 循环逻辑：默认的循环是按10行间隔检查（第10、20...1000行），对应你描述的“第10行值为Yes对应的第4行”的组逻辑。如果你的需求是连续检查第10行到第109行（共100行），只需要把循环语句改成：

  For i = 10 To 109
  

可自定义的选项 #

1. 复制整行或带格式：如果你需要复制整行或者保留单元格格式，可以把赋值语句改成复制粘贴的方式：

   ' 复制整行并粘贴
   sourceWs.Rows(i - 6).Copy targetWs.Rows(nextTargetRow)
   ' 或者只复制B列带格式
   sourceWs.Cells(i - 6, "B").Copy
   targetWs.Cells(nextTargetRow, "B").PasteSpecial xlPasteAll
   Application.CutCopyMode = False ' 清除剪贴板状态
   

2. 调整起始行或检查范围：如果需要从其他行开始检查，或者修改检查的行数，直接调整循环的起始值、结束值和步长即可。

怎么使用这个脚本 #

1. 打开你的Excel工作簿，按下Alt + F11打开VBA编辑器。
2. 右键点击左侧的工作簿名称，选择「插入」→「模块」。
3. 把上面的代码粘贴到新建的模块里。
4. 按下F5运行脚本，或者回到Excel界面，通过「开发工具」→「宏」找到CopyQualifiedCells并运行。

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