复选框，仅复制选定的单元格并粘贴到另一个工作表

Question

我在这方面不是很先进，但我希望获得一些方向。我目前正在运行以下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

但是，它最终只复制最后选中的复选框，而不是一次复制多个单元格。为了在每个复选框中只复制选定的单元格并将它们复制到同一工作簿中的另一个工作表中，我缺少什么?

Answer 1

下面是一个粗糙但有效的例子:

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

复制范围取决于复选框的值

标准模块，例如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模块，例如UserForm1

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