我在這方面不是很先進，但是我希望獲得一些指導。我目前正在運行以下 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
但是，它最終只會復制最后選擇的復選框，而不是一次復制多個單元格。為了僅復制每個復選框的選定單元格并將它們復制到同一作業簿中的另一個作業表，我缺少什么？
uj5u.com熱心網友回復：
這是一個粗略但有效的例子：
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
uj5u.com熱心網友回復：
根據復選框的值復制范圍
標準模塊例如 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
Private Sub CommandButton1_Click()
Dim chkBoxes As Variant
chkBoxes = Array(CheckBox1, CheckBox2, CheckBox3, CheckBox4) ' add more
CopyChkBoxConsecutiveRanges chkBoxes
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/net/335712.html