带复选框的合并单元格对应Y:AB行复制至新工作簿的VBA问题

修改后的代码 #

Sub copySelected()
    Dim shtSource As Worksheet
    Dim wbDest As Workbook
    Dim wsDest As Worksheet
    Dim cb As CheckBox
    Dim mergeArea As Range
    Dim sourceCopyRng As Range
    Dim destRow As Long
    
    ' 初始化源工作表与目标工作簿
    Set shtSource = ThisWorkbook.Worksheets("Sheet1")
    Set wbDest = Workbooks.Add
    Set wsDest = wbDest.Sheets("Sheet1")
    destRow = 15 ' 固定粘贴起始行Y15
    
    For Each cb In shtSource.CheckBoxes
        If cb.Value = 1 Then ' 仅处理勾选状态的复选框
            ' 获取复选框所在的合并单元格区域
            Set mergeArea = cb.TopLeftCell.MergeArea
            ' 锁定要复制的Y:AB列对应合并区域的完整行范围
            Set sourceCopyRng = shtSource.Range("Y" & mergeArea.Row & ":AB" & mergeArea.Row + mergeArea.Rows.Count - 1)
            
            ' 分步骤粘贴值+数字格式、单元格格式、列宽
            sourceCopyRng.Copy
            wsDest.Range("Y" & destRow).PasteSpecial xlPasteValuesAndNumberFormats
            
            sourceCopyRng.Copy
            wsDest.Range("Y" & destRow).PasteSpecial xlPasteFormats
            
            sourceCopyRng.Columns.Copy
            wsDest.Range("Y" & destRow).Resize(, sourceCopyRng.Columns.Count).PasteSpecial xlPasteColumnWidths
            
            ' 更新下一次粘贴的起始行
            destRow = destRow + sourceCopyRng.Rows.Count
        End If
    Next cb
    
    ' 清除剪贴板，避免Mac环境下的弹窗提示
    Application.CutCopyMode = False
End Sub

关键修改说明 #

• 合并单元格适配：通过cb.TopLeftCell.MergeArea获取复选框所在的完整合并区域，再计算对应Y:AB列的行范围，解决了单行逻辑无法覆盖跨多行合并单元格的问题。
• 固定粘贴起始位置：用destRow变量固定初始值为15，每次粘贴后累加复制的行数，确保始终从Y15开始依次向下粘贴，替代原代码中“找最后一行”的逻辑。
• 列宽粘贴优化：单独复制源区域的列宽并粘贴到目标列，避免列宽应用错位。
• Mac环境兼容：添加Application.CutCopyMode = False清除剪贴板，避免Mac上出现不必要的弹窗；若遇到PasteSpecial常量失效，可替换为对应数值：
  • xlPasteValuesAndNumberFormats → 46
  • xlPasteFormats → -4122
  • xlPasteColumnWidths → 8

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