Question

＆＃39;在朋友（主要是他）的帮助下，我们编写了一些代码，将5个可打印区域中的任意一个添加到打印区域，以便根据5个相应的复选框添加工作表。单击框将执行添加到打印区域，而另一个更简单的命令行会清除它。以下作品完美无缺，所以我想分享它，如果有人有不同或更简洁的方式去做，我们很想看到它。他很少在VBA打球，所以他不得不通过它来蛮力。无论如何，这是：

Private Sub Message_Click()

Dim Ranges() As Range
Dim rangeCount As Integer
rangeCount = 0

If ActiveSheet.OLEObjects("PrintArea1").Object.Value Then
    rangeCount = rangeCount + 1
    ReDim Preserve Ranges(rangeCount)
    Set Ranges(rangeCount) = Range("Sect1PULC", Range("Sect1PLLC").Offset(0, 1))
End If
If ActiveSheet.OLEObjects("PrintArea2").Object.Value Then
    rangeCount = rangeCount + 1
    ReDim Preserve Ranges(rangeCount)
    Set Ranges(rangeCount) = Range(Range("Sect2PULC"), Range("Sect2PLLC").Offset(0, 1))
End If
If ActiveSheet.OLEObjects("PrintArea3").Object.Value Then
    rangeCount = rangeCount + 1
    ReDim Preserve Ranges(rangeCount)
    Set Ranges(rangeCount) = Range(Range("Sect3PULC"), Range("Sect3PLLC").Offset(0, 1))
End If
If ActiveSheet.OLEObjects("PrintArea4").Object.Value Then
    rangeCount = rangeCount + 1
    ReDim Preserve Ranges(rangeCount)
    Set Ranges(rangeCount) = Range(Range("Sect4PULC"), Range("Sect4PLLC").Offset(0, 1))
End If
If ActiveSheet.OLEObjects("PrintArea5").Object.Value Then
    rangeCount = rangeCount + 1
    ReDim Preserve Ranges(rangeCount)
    Set Ranges(rangeCount) = Range(Range("Sect5aPULC"), Range("Sect5aPLLC").Offset(0, 1))

    rangeCount = rangeCount + 1
    ReDim Preserve Ranges(rangeCount)
    Set Ranges(rangeCount) = Range(Range("Sect5bPULC"), Range("Sect5bPLLC").Offset(0, 1))
End If


Dim PrintSection As Range
If rangeCount = 0 Then Exit Sub
If rangeCount = 1 Then Set PrintSection = Ranges(1)
If rangeCount = 2 Then Set PrintSection = Application.Union(Ranges(1), Ranges(2))
If rangeCount = 3 Then Set PrintSection = Application.Union(Ranges(1), Ranges(2), Ranges(3))
If rangeCount = 4 Then Set PrintSection = Application.Union(Ranges(1), Ranges(2), Ranges(3), Ranges(4))
If rangeCount = 5 Then Set PrintSection = Application.Union(Ranges(1), Ranges(2), Ranges(3), Ranges(4), Ranges(5))
If rangeCount = 6 Then Set PrintSection = Application.Union(Ranges(1), Ranges(2), Ranges(3), Ranges(4), Ranges(5), Ranges(6))

With ActiveSheet.PageSetup
 .PrintArea = PrintSection.Address
 .Orientation = xlPortrait
 .Zoom = False
 .FitToPagesWide = 1
 .FitToPagesTall = False
 .CenterHorizontally = True
End With

End Sub

Answer 1

我会跳过计数器和范围数组。只需定义一个范围并添加即可。类似的东西：

Dim wks As Worksheet, rngPrint As Range
Set wks = ActiveSheet

If wks.OLEObjects("CheckBox1").Object.Value = True Then
    If rngPrint Is Nothing Then
        Set rngPrint = wks.Range("I4:L9")
    Else
        Set rngPrint = Union(rngPrint, wks.Range("I4:L9"))
    End If
End If

If wks.OLEObjects("CheckBox2").Object.Value = True Then
    If rngPrint Is Nothing Then
        Set rngPrint = wks.Range("I12:L17")
    Else
        Set rngPrint = Union(rngPrint, wks.Range("I12:L17"))
    End If
End If

Answer 2

是的，你可以通过利用你在复选框和命名范围上做出的命名约定来简化它并将其缩短很多。

Private Sub Message_Click()
  Dim prtArea As String, i As Long
  For i = 1 To 5
    If Sheet2.OLEObjects("PrintArea" & i).Object.Value Then
        If Len(prtArea) > 0 Then prtArea = prtArea & ","
        prtArea = prtArea & Range("Sect" & i & "PULC").Address & ":" & _
          Range("Sect" & i & "PLLC").Offset(0, 1).Address
    End If
  Next

  With ActiveSheet.PageSetup
   .PrintArea = prtArea
   .Orientation = xlPortrait: .Zoom = False: .FitToPagesWide = 1
   .FitToPagesTall = False: .CenterHorizontally = True
  End With
End Sub

另请注意，这可以让您获得比您拥有的更多控制权，因为您可以任意选择这些部分，例如，如果您只想打印section 1，则代码必须包含section 2。

使用复选框设置不连续的打印区域

2 个答案: