vendredi 9 juin 2023

Get values to left and right of merged cell with checkbox VBA Macro

@FunThomas answered this in part I. https://stackoverflow.com/a/76439568/21278470

enter image description here

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