For Each...Next语句异常：VBA复制勾选行重复且仅读取当前工作表

我有多个包含各类财务报价的QChecklist工作表，部分行使用*Marlett字体的字母"a"*作为勾选标记。期望通过VBA代码识别勾选行并复制到QAnalysisForm汇总工作表，原代码如下：

Private Sub CopyRows()
 Dim cel2 As Range
 ScreenUpdating = False
 With Sheets("QChecklist1")
 For Each Cell In .Range("E8:E30")
 If Cell.Value = "a" Then
 Set cel2 = Sheets("QAnalysisForm").Range("B" & Rows.Count).End(xlUp).Offset(1)
 Rows(Cell.Row).Resize(, 10).Offset(, 1).Copy cel2
 cel2.Value = cel2.Value
 Set cel2 = Nothing
 End If
 Next
 End With
 With Sheets("QChecklist2")
 For Each Cell In .Range("E8:E30")
 If Cell.Value = "a" Then
 Set cel2 = Sheets("QAnalysisForm").Range("B" & Rows.Count).End(xlUp).Offset(1)
 Rows(Cell.Row).Resize(, 10).Offset(, 1).Copy cel2
 cel2.Value = cel2.Value
 Set cel2 = Nothing
 End If
 Next
 End With
 With Sheets("QChecklist3")
 For Each Cell In .Range("E8:E30")
 If Cell.Value = "a" Then
 Set cel2 = Sheets("QAnalysisForm").Range("B" & Rows.Count).End(xlUp).Offset(1)
 Rows(Cell.Row).Resize(, 10).Offset(, 1).Copy cel2
 cel2.Value = cel2.Value
 Set cel2 = Nothing
 End If
 Next
 End With
 With Sheets("QChecklist4")
 For Each Cell In .Range("E8:E30")
 If Cell.Value = "a" Then
 Set cel2 = Sheets("QAnalysisForm").Range("B" & Rows.Count).End(xlUp).Offset(1)
 Rows(Cell.Row).Resize(, 10).Offset(, 1).Copy cel2
 cel2.Value = cel2.Value
 Set cel2 = Nothing
 End If
 Next
 End With
 Sheets("QAnalysisForm").Activate
 cells(1, 1).Select
 On Error Resume Next
 ScreenUpdating = True
End Sub

运行后出现两个异常：

• 复制的行大量重复（如QChecklist1的4条勾选行最终生成14条）
• 仅能读取存放宏按钮的工作表数据，无法读取其他QChecklist工作表的勾选行

问题原因分析 #

1. 未限定Rows对象的父工作表：在With Sheets("QChecklistX")块中，Rows(Cell.Row)没有指定父对象，默认会引用当前激活的工作表（即宏按钮所在的工作表）。所以循环其他工作表的单元格时，复制的始终是激活表的行，导致重复条目且无法读取目标表数据。
2. 代码冗余：重复的循环逻辑增加了出错概率，也不利于后续维护。

修改后的代码 #

Private Sub CopyRows()
    Dim cel2 As Range
    Dim wsChecklist As Worksheet
    Dim cell As Range
    Dim targetSheet As Worksheet
    
    ScreenUpdating = False
    Set targetSheet = Sheets("QAnalysisForm")
    
    ' 遍历所有目标QChecklist工作表
    For Each wsChecklist In ThisWorkbook.Sheets
        If wsChecklist.Name Like "QChecklist*" Then ' 自动匹配所有以QChecklist开头的工作表
            For Each cell In wsChecklist.Range("E8:E30")
                If cell.Value = "a" Then
                    ' 获取目标表的下一个空行
                    Set cel2 = targetSheet.Range("B" & targetSheet.Rows.Count).End(xlUp).Offset(1)
                    ' 明确指定复制当前Checklist工作表的行
                    wsChecklist.Rows(cell.Row).Resize(, 10).Offset(, 1).Copy cel2
                    ' 仅保留值，清除格式/公式
                    cel2.Value = cel2.Value
                    Set cel2 = Nothing
                End If
            Next cell
        End If
    Next wsChecklist
    
    targetSheet.Activate
    targetSheet.Cells(1, 1).Select
    ScreenUpdating = True
End Sub

关键改进点 #

• 明确指定父对象：所有工作表对象（如wsChecklist.Rows、targetSheet.Rows）都明确关联对应的工作表，彻底避免引用错误。
• 批量遍历工作表：用Like "QChecklist*"自动匹配所有目标工作表，无需重复编写With块，后续新增QChecklist工作表也无需修改代码。
• 优化目标行获取：提前定义targetSheet变量，减少重复调用Sheets("QAnalysisForm")，提升代码运行效率。

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