VBA实现将勾选复选框的行复制到新工作表的问题求助

问题分析 #

你的代码存在三个核心问题：

• 变量名错误：WS2.Cells(Row, "A")中的Row未定义，应该使用声明好的Row1
• 目标工作表错误：直接指定了原工作表Sheet1，没有创建/指向新工作表
• 未复制表头：仅复制勾选行数据，遗漏了表头行

修正代码 #

Sub Copy_to_new_sheet()
    Dim Row1 As Long, ChkBx As CheckBox
    Dim sourceWS As Worksheet, targetWS As Worksheet
    Dim targetSheetName As String
    
    ' 设置源工作表为当前活动表，目标工作表名称可自定义
    Set sourceWS = ActiveSheet
    targetSheetName = "筛选结果表"
    
    ' 检查目标工作表是否存在，不存在则新建
    On Error Resume Next
    Set targetWS = ThisWorkbook.Worksheets(targetSheetName)
    On Error GoTo 0
    If targetWS Is Nothing Then
        Set targetWS = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        targetWS.Name = targetSheetName
        ' 复制表头到新工作表
        sourceWS.Range("A1").Resize(, 14).Copy targetWS.Range("A1")
        Row1 = 1 ' 表头已占第1行，后续数据从第2行开始
    Else
        ' 如果目标表已存在，从已有数据的下一行开始
        Row1 = targetWS.Range("A" & targetWS.Rows.Count).End(xlUp).Row
    End If
    
    ' 遍历勾选的复选框，复制对应行数据
    For Each ChkBx In sourceWS.CheckBoxes
        If ChkBx.Value = 1 Then
            Row1 = Row1 + 1
            ' 复制对应行的14列数据到目标表
            targetWS.Cells(Row1, "A").Resize(, 14).Value = sourceWS.Range("A" & ChkBx.TopLeftCell.Row).Resize(, 14).Value
        End If
    Next
End Sub

关键改动说明 #

• 新增目标表判断逻辑：自动检测是否存在指定名称的工作表，不存在则新建，避免重复创建或报错
• 添加表头复制：新建工作表时直接复制源表的表头行（第1行），确保表头不缺失
• 修复变量错误：将Row改为声明好的Row1，避免运行时错误
• 明确源/目标工作表：用sourceWS和targetWS区分，代码逻辑更清晰

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