I'm not very advanced in this however I'm hoping to obtain some direction. I'm currently running the following VBA:

Private Sub CommandButton1_Click()

If (CheckBox1.Value = True) Then
        ActiveSheet.Range("B13:E18").Copy
    End If

If (CheckBox2.Value = True) Then
        ActiveSheet.Range("B20:E25").Copy
    End If

If (CheckBox3.Value = True) Then
        ActiveSheet.Range("B27:E32").Copy
    End If
    
If (CheckBox4.Value = True) Then
        ActiveSheet.Range("B34:E39").Copy
    End If

    'copy the chunk above for more check boxes

End Sub

However, it only ends up copying the last selected checkbox instead of multiple cells at once. What am I missing in order to copy only selected cells per a checkbox and copying them over to another worksheet within the same workbook?

CodePudding user response：

Here's a crude but working example:

Public Sub CommandButton1_Click()

    Dim rgCopy As Range
    
    With ActiveSheet
        If CheckBox1 Then
            Set rgCopy = .Range("B13:E18")
        End If
        
        If CheckBox2 Then
            If rgCopy Is Nothing Then
                Set rgCopy = .Range("B20:E25")
            Else
                Set rgCopy = Union(rgCopy, .Range("B20:E25"))
            End If
        End If
        
        If CheckBox3 Then
            If rgCopy Is Nothing Then
                Set rgCopy = .Range("B27:E32")
            Else
                Set rgCopy = Union(rgCopy, .Range("B27:E32"))
            End If
        End If
        
        If CheckBox4 Then
            If rgCopy Is Nothing Then
                Set rgCopy = .Range("B34:E39")
            Else
                Set rgCopy = Union(rgCopy, .Range("B34:E39"))
            End If
        End If
    End With
    
    If Not rgCopy Is Nothing Then
        rgCopy.Copy
    Else
        MsgBox "nothing selected message"
    End If

End Sub

CodePudding user response：

Copy Ranges Depending on Checkboxes' Value

Standard Module e.g. Module1

Option Explicit

Sub CopyChkBoxConsecutiveRanges(ByVal chkBoxes As Variant)
    
    ' Source
    Const sName As String = "Sheet1"
    Const sfrgAddress As String = "B13:E18"
    Const sGap As Long = 1
    ' Destination
    Const dName As String = "Sheet2"
    Const dfCellAddress As String = "A2"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = RefChkBoxConsecutiveRanges( _
        sws.Range(sfrgAddress), chkBoxes, sGap)
    'Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range: Set dfCell = dws.Range(dfCellAddress)
    
    ' Copy
    If Not srg Is Nothing Then
        srg.Copy dfCell
    End If
    
End Sub

Function RefChkBoxConsecutiveRanges( _
    ByVal sfrg As Range, _
    ByVal chkBoxes As Variant, _
    Optional ByVal sGap As Long = 0, _
    Optional ByVal SearchOrder As XlSearchOrder = xlByRows) _
As Range
' Needs `RefCombinedRange`.
    
    Dim sws As Worksheet: Set sws = sfrg.Worksheet
    Dim srOffset As Long
    srOffset = IIf(SearchOrder = xlByRows, sfrg.Rows.Count   sGap, 0)
    Dim scOffset As Long
    scOffset = IIf(SearchOrder = xlByRows, 0, sfrg.Columns.Count   sGap)
    Dim scrg As Range: Set scrg = sfrg
        
    Dim srg As Range
    Dim n As Long
    
    For n = LBound(chkBoxes) To UBound(chkBoxes)
        If chkBoxes(n) Then
            Set srg = RefCombinedRange(srg, scrg)
        End If
        Set scrg = scrg.Offset(srOffset, scOffset)
    Next n
    
    If Not srg Is Nothing Then
        Set RefChkBoxConsecutiveRanges = srg
    End If
    
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to a range combined from two ranges.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCombinedRange( _
    ByVal CombinedRange As Range, _
    ByVal AddRange As Range) _
As Range
    If CombinedRange Is Nothing Then
        Set RefCombinedRange = AddRange
    Else
        Set RefCombinedRange = Union(CombinedRange, AddRange)
    End If
End Function

Userform Module e.g. UserForm1

Private Sub CommandButton1_Click()
    Dim chkBoxes As Variant
    chkBoxes = Array(CheckBox1, CheckBox2, CheckBox3, CheckBox4) ' add more
    CopyChkBoxConsecutiveRanges chkBoxes
End Sub