@FunThomas在第一部分回答了这个问题。https://stackoverflow.com/a/76439568/21278470
我现在的问题是，我正在修改代码，以便也捕获复选框左侧的范围B：I。目前它只设置为抓取Y：AB
这是下面的代码，它可以正确地只抓取一个范围;然而，无论我如何尝试修改它，它似乎是设置只有一个范围。
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") '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...
' 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
If row < 15 Then row = 15
With .Cells(row, "Y")
.PasteSpecial xlPasteValuesAndNumberFormats '...Paste info
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteColumnWidths
End With
End With
End If
Next cb
End Sub我写了下面的VBA来使用union复制范围B：I和Y：AB，但只有格式是粘贴，没有文本。代码只抓取一个复选框行，而不是所有选中的行。
有没有办法修改第一段代码来获取合并行的多个范围？
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") '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...
' Figure out the area of data we want to copy
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 '...copy the corresponding range of data...
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 '...Paste info
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteColumnWidths
End With
End With
End If
Next cb
End Sub
2条答案
按热度按时间anauzrmj1#
修改后的代码所面临的问题是，您正确地复制了范围，但在粘贴时，您只粘贴了目标工作表的B列，而不是相应的列。此外，代码未设置为处理多个选中的行。
要修改代码以获取合并行的多个范围并正确粘贴它们，可以进行以下更改：
将With .Cells（row，“B”）行替换为With .Cells（row，“B”）.Resize（，multiplerange. Columnes.Count）。这将确保数据被粘贴到目标工作表中的相应列中。
若要处理多个选中的行，可以修改代码以分别复制和粘贴每个范围。下面是代码的更新版本：
代码-
Sub copySelected（）Dim shtSource As Worksheet Dim wbDest As Workbook Dim wsDest As Worksheet Dim cb As CheckBox Dim destRow As Long
结束子
此更新的代码将复制并粘贴每个选中行的范围B：I和Y：AB，对齐目标工作表相应列中的数据。它还将适当地递增目标行以粘贴后续范围。
2w3kk1z52#
啊，我发现问题了。我不得不删除Destination：=wsDest.Cells（destRow，“B”），然后现在一切都正常了。唯一问题：它将不接受在不覆盖所有内容情况下将列宽粘贴为行项目。因此，为了解决这个问题，我添加了一个单独的复制和粘贴只是列宽度后，复选框功能完成。这可能不是最干净的，但它现在是一个完全有效的解决方案。