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

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

UserForm1表单模块，例如UserForm1

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