基于单元格文本用For循环复制整行的VBA代码报错求助

原代码存在的问题 #

• 工作簿引用错误：Workbooks(Book1) 未用字符串包裹，应指定文件名或使用ThisWorkbook更稳妥
• lastrow变量未赋值，循环无法正常执行
• 语法错误：ActiveSheetCells(i, 2) 缺少点号，正确写法为ActiveSheet.Cells(i, 2)
• 遍历范围错误：原代码遍历所有工作表，需求仅需遍历Sheet1和Sheet2
• 复制行的方法错误：Insert无法实现整行复制，需用Copy+Paste或直接赋值逻辑
• 逻辑混乱：存在无意义的条件判断且缺少语句块
• 依赖ActiveSheet和Select，易引发错误且运行效率低

修正后的代码 #

Sub CopyInProgressRows()
    Dim wb As Workbook
    Dim sourceWs As Worksheet
    Dim targetWs As Worksheet
    Dim lastRow As Long
    Dim targetLastRow As Long
    Dim i As Long
    
    ' 引用当前运行代码的工作簿，避免外部文件引用错误
    Set wb = ThisWorkbook
    ' 指定目标工作表Sheet4
    Set targetWs = wb.Worksheets("Sheet4")
    
    ' 仅遍历需求中的Sheet1和Sheet2
    For Each sourceWs In wb.Worksheets(Array("Sheet1", "Sheet2"))
        ' 获取当前源工作表B列的最后非空行
        lastRow = sourceWs.Cells(sourceWs.Rows.Count, "B").End(xlUp).Row
        
        ' 遍历源工作表的每一行
        For i = 1 To lastRow
            ' 判断当前行B列内容是否为"In Progress"
            If sourceWs.Cells(i, "B").Value = "In Progress" Then
                ' 获取目标工作表的最后非空行，确定粘贴位置
                targetLastRow = targetWs.Cells(targetWs.Rows.Count, "A").End(xlUp).Row
                ' 复制整行到目标工作表的下一行
                sourceWs.Rows(i).Copy Destination:=targetWs.Rows(targetLastRow + 1)
            End If
        Next i
    Next sourceWs
    
    MsgBox "复制完成！", vbInformation
End Sub

代码说明 #

• 用ThisWorkbook确保引用当前工作簿，避免文件名变更导致的错误
• 明确指定遍历Sheet1和Sheet2，严格匹配需求
• 通过Cells(Rows.Count, "B").End(xlUp).Row精准获取工作表最后非空行，减少无效遍历
• 直接通过工作表对象操作，摒弃ActiveSheet和Select，提升代码稳定性与效率
• 使用Copy Destination方法直接完成整行复制，逻辑简洁高效
• 增加完成提示框，便于确认操作结果

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