@FunThomas answered this in part I. https://stackoverflow.com/a/76439568/21278470
My question now, I am modifying the code to ALSO capture the ranges B:I to the left of the checkbox. Currently it is only set up for grabbing Y:AB
This is the code below that works correctly for grabbing only one range; however no matter how I try to modify it, it seems like it is setup only to have one range.
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
I wrote the below VBA to copy the ranges B:I and Y:AB using union, but only the formatting is pasting, no text. And the Code only grabs one checkbox row instead of all checked rows.
Any way to modify the first code to grab multiple ranges of this merged row?
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
Aucun commentaire:
Enregistrer un commentaire