Checkbox to copy selected cells only and paste to another worksheet - excel

Question

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?

Answer 1

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

Answer 2

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