复制带有复选框的合并单元格旁边的行并粘贴到新工作簿中

Question

我正在编写代码，但缺乏足够的知识来实现​​如此独特的东西。我在合并单元格中有一个复选框（参见 T 列）。我们单击一个按钮，它应该只获取该合并区域的 Y:AB 行并将它们复制/粘贴到新工作簿中。它应该循环遍历所有复选框，并仅将选中的项目粘贴到下一组下方。

我成功地用单行做到了这一点。

这是在我弄乱合并单元格之前一直有效的代码。不确定我是否可以尝试.MergeArea.Copy。另请注意，此处在 Mac 上工作。

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("Sheet1") 'where the data is
   Set wbDest = Workbooks.Add
    Set wsDest = wbDest.Sheets("Sheet1")
    
For Each cb In shtSource.CheckBoxes 'loop through all checkboxes
    If cb.Value = 1 Then 'if the checkbox has been selected then...
        shtSource.Range("Y" & cb.TopLeftCell.Row, "AB" & cb.TopLeftCell.Row).Copy '...copy the corresponding range of data...
        With wsDest
            .Range("Y" & .Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats '...this only pastes into the first empty row in the destination sheet, which is an issue. Would prefer pasting starting on Y15
               .Range("Y" & .Rows.Count).End(xlUp).Offset(0, 0).PasteSpecial xlPasteFormats 
                  .Range("Y" & .Rows.Count).End(xlUp).Offset(0, 0).PasteSpecial xlPasteColumnWidths 
            
        End With
    End If
    Next cb
    End Sub ```

Answer 1

当谈到编程时，合并单元格是一个烦恼。您需要知道的主要事情是，如果单元格是合并区域的一部分，您可以使用MergedArea单元格的属性。

现在你需要做的就是弄清楚

• 真正的第一行：使用cb.TopLeftCell.MergeArea.Row
• 您要复制的行数：使用cb.TopLeftCell.MergeArea.Rows.Count

知道了这一点，你的代码可能看起来像这样

For Each cb In shtSource.CheckBoxes 'loop through all checkboxes
If cb.Value = 1 Then 'if the checkbox has been selected then...
    ' Figure out the area of data we want to copy
    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    '...copy the corresponding range of data...
    With wsDest
        Dim row As Long
        row = .Range("Y" & .Rows.Count).End(xlUp).row + 1
        With .Cells(row, "Y")
            .PasteSpecial xlPasteValuesAndNumberFormats '...this only pastes into the first empty row in the destination sheet, which is an issue. Would prefer pasting starting on Y15
            .PasteSpecial xlPasteFormats
            .PasteSpecial xlPasteColumnWidths
        End With
    End With
End If
Next cb