如何修改VBA宏以复制复选框合并行的多列区域？

原VBA宏可正常复制复选框所在合并行的Y:AB区域，现在需要扩展为同时复制左侧B:I区域。尝试用Union合并两个区域后，出现以下问题：

• 仅粘贴格式，无文本内容
• 只抓取到一行勾选的数据

初始可行代码 #

Sub copySelected()
Dim shtSource As Worksheet
Dim wbDest As Workbook
Dim sourceRng As Range
Dim wsDest As Worksheet
Dim cb As CheckBox


Set shtSource = ThisWorkbook.Worksheets("RFQ FORM INT") '数据所在工作表
   Set wbDest = Workbooks.Add
    Set wsDest = wbDest.Sheets("Sheet1")
    
For Each cb In shtSource.CheckBoxes '遍历所有复选框
If cb.Value = 1 Then '若复选框被勾选
    ' 定义要复制的数据区域
    Dim sourceRange As Range
    Set sourceRange = shtSource.Range("Y" & cb.TopLeftCell.MergeArea.row, "AB" & cb.TopLeftCell.row)
    Set sourceRange = sourceRange.Resize(cb.TopLeftCell.MergeArea.Rows.Count)
    sourceRange.Copy    '复制对应数据区域
    With wsDest
        Dim row As Long
        row = .Range("Y" & .Rows.Count).End(xlUp).row + 1
        If row < 15 Then row = 15
        With .Cells(row, "Y")
            .PasteSpecial xlPasteValuesAndNumberFormats '粘贴值和数字格式
            .PasteSpecial xlPasteFormats '粘贴格式
            .PasteSpecial xlPasteColumnWidths '粘贴列宽
        End With
    End With
End If
Next cb
End Sub

尝试代码（存在问题） #

Sub copySelected()
Dim shtSource As Worksheet
Dim wbDest As Workbook
Dim sourceRng As Range
Dim wsDest As Worksheet
Dim cb As CheckBox


Set shtSource = ThisWorkbook.Worksheets("RFQ FORM INT") '数据所在工作表
   Set wbDest = Workbooks.Add
    Set wsDest = wbDest.Sheets("Sheet1")
    
For Each cb In shtSource.CheckBoxes '遍历所有复选框
If cb.Value = 1 Then '若复选框被勾选
    ' 定义要复制的数据区域
    Dim sourceRange1 As Range, sourceRange2 As Range, multiplerange As Range
    Set sourceRange1 = shtSource.Range("Y" & cb.TopLeftCell.MergeArea.row, "AB" & cb.TopLeftCell.row)
    Set sourceRange1 = sourceRange1.Resize(cb.TopLeftCell.MergeArea.Rows.Count)
    Set sourceRange2 = shtSource.Range("B" & cb.TopLeftCell.MergeArea.row, "I" & cb.TopLeftCell.row)
    Set sourceRange2 = sourceRange2.Resize(cb.TopLeftCell.MergeArea.Rows.Count)
    Set multiplerange = Application.Union(sourceRange1, sourceRange2)
    multiplerange.Copy    '复制对应数据区域
    
    With wsDest
        Dim row As Long
        row = .Range("B" & .Rows.Count).End(xlUp).row + 1
        If row < 15 Then row = 15
        With .Cells(row, "B")
            .PasteSpecial xlPasteValuesAndNumberFormats '粘贴值和数字格式
            .PasteSpecial xlPasteFormats '粘贴格式
            .PasteSpecial xlPasteColumnWidths '粘贴列宽
        
        End With
    End With
End If
Next cb
End Sub

问题原因 #

1. 非连续区域粘贴异常：Union合并的B:I和Y:AB是非连续区域，直接粘贴到单个单元格时，Excel无法正确映射非连续区域的内容，导致仅格式被保留、数据丢失。
2. 行号判断逻辑错误：尝试代码中用B列判断目标行，若B列无初始数据，End(xlUp)会跳转至工作表最后一行，导致行号计算错误，最终仅能粘贴一行数据。

修正后的代码 #

Sub copySelected()
    Dim shtSource As Worksheet
    Dim wbDest As Workbook
    Dim wsDest As Worksheet
    Dim cb As CheckBox
    Dim targetRow As Long
    Dim mergeRowCount As Long
    
    Set shtSource = ThisWorkbook.Worksheets("RFQ FORM INT")
    Set wbDest = Workbooks.Add
    Set wsDest = wbDest.Sheets("Sheet1")
    
    ' 初始化目标起始行
    targetRow = 15
    
    For Each cb In shtSource.CheckBoxes
        If cb.Value = 1 Then
            mergeRowCount = cb.TopLeftCell.MergeArea.Rows.Count
            
            ' 复制B:I区域到目标B列起始行
            shtSource.Range("B" & cb.TopLeftCell.MergeArea.Row, "I" & cb.TopLeftCell.MergeArea.Row + mergeRowCount - 1).Copy
            With wsDest.Cells(targetRow, "B")
                .PasteSpecial xlPasteValuesAndNumberFormats
                .PasteSpecial xlPasteFormats
                .PasteSpecial xlPasteColumnWidths
            End With
            
            ' 复制Y:AB区域到目标Y列起始行
            shtSource.Range("Y" & cb.TopLeftCell.MergeArea.Row, "AB" & cb.TopLeftCell.MergeArea.Row + mergeRowCount - 1).Copy
            With wsDest.Cells(targetRow, "Y")
                .PasteSpecial xlPasteValuesAndNumberFormats
                .PasteSpecial xlPasteFormats
                .PasteSpecial xlPasteColumnWidths
            End With
            
            ' 更新目标行到下一个空行
            targetRow = targetRow + mergeRowCount
        End If
    Next cb
    
    Application.CutCopyMode = False ' 清除剪贴板复制状态
End Sub

关键修改点 #

1. 分区域独立复制：放弃Union合并，分别处理B:I和Y:AB两个连续区域的复制粘贴，确保内容和格式都能正确映射到目标位置。
2. 固定起始行+动态递增：初始化目标行从15开始，每处理完一个勾选项，根据合并行的数量递增目标行，避免行号判断错误。
3. 释放剪贴板资源：最后添加Application.CutCopyMode = False，清除复制状态，避免后续操作受影响。

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