基于下拉值实现跨工作表数据复制的VBA宏故障排查

原代码无法正常运行的核心问题 #

• 逻辑完全错位：原代码的设计目标是匹配A2单元格的工作表名称，但实际代码逻辑是遍历每个工作表内部嵌入的*ListObject（超级表）*名称，和A2的值做比对——相当于本来想找叫“Sheet2”的工作表，结果代码翻遍所有工作表找里面叫“Sheet2”的嵌入超级表，自然找不到目标，也就不会执行任何复制操作
• 粘贴范围硬编码：原代码把粘贴范围写死成B6:Q22，如果源工作表的实际内容超出这个范围就会漏贴，范围不足的话还会残留上次粘贴的旧内容
• 状态恢复漏洞：原代码在匹配到目标后直接用Exit Sub跳出流程，会跳过后面恢复Application.ScreenUpdating = True的语句，后续操作Excel时会出现界面卡顿、刷新延迟的问题
• 无基础合法性校验：如果A2单元格选中的内容不是有效工作表名，代码会直接触发系统报错，没有友好提示；也没做逻辑判断避免把Sheet1本身的内容往自身粘贴

可直接使用的修正版代码 #

Sub Button21_Click()
    Dim wb As Workbook
    Dim targetWs As Worksheet
    Dim criteria As String
    
    ' 错误兜底，确保哪怕运行出错也能恢复Excel默认状态
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    
    Set wb = ThisWorkbook
    criteria = wb.Sheets("Sheet1").Range("A2").Value
    
    ' 校验选中值是否为有效工作表
    On Error Resume Next
    Set targetWs = wb.Sheets(criteria)
    On Error GoTo ErrHandler
    If targetWs Is Nothing Then
        MsgBox "下拉选择的「" & criteria & "」不是有效工作表，请重新选择", vbExclamation
        GoTo Cleanup
    End If
    ' 禁止复制Sheet1本身
    If targetWs.Name = "Sheet1" Then
        MsgBox "不能选择Sheet1作为复制源", vbExclamation
        GoTo Cleanup
    End If
    
    ' 清空B6起始区域的旧内容，避免新旧数据重叠残留
    wb.Sheets("Sheet1").Range("B6").CurrentRegion.Clear
    ' 复制源工作表全部已用内容，粘贴到B6起始位置
    targetWs.UsedRange.Copy Destination:=wb.Sheets("Sheet1").Range("B6")

Cleanup:
    ' 恢复屏幕刷新，释放对象内存
    Application.ScreenUpdating = True
    Set targetWs = Nothing
    Set wb = Nothing
    Exit Sub
ErrHandler:
    MsgBox "运行出错：" & Err.Description, vbCritical
    Resume Cleanup
End Sub

配套使用说明 #

• 代码完全匹配需求：下拉选中哪个工作表，就会自动把该表的全部有效内容复制到Sheet1从B6单元格开始的位置
• 自动适配内容大小：不需要手动调整粘贴的行列范围，源工作表有多少有效内容就对应粘贴多少
• 自动清理旧数据：每次粘贴前会清空上次粘贴的残留内容，不会出现新旧数据重叠的问题
• 增加了友好提示：遇到无效选择、运行报错的情况会弹出明确提示，不会直接弹出系统报错框

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