如何收集从VBA中的for循环创建的所有打印预览？

问题描述

我有一个列表框，我希望从该列表框中以单次打印预览为所有选定客户打印预览报告。 youtube上有一个与此-> https://youtu.be/962Hd4akras相关的视频，如果您在单独的工作表上有数据，则可以了解如何实现该视频。但就我而言，我正在使用for循环来获取选定客户的数据。我正在一张一张地收集数据，并将其放到一个表格中，在其中进行一些格式化。我的代码为每个选定的客户提供了单独的打印预览。但是我想要的是为所有客户获得组合的打印预览（多页打印预览）。这是我的代码。注意：我有固定的工作表以及打印区域。

Sub SlipMacro2()

'Getting customer code number

Dim i,c,d As Long,FarmerCode As Integer
Dim SlipArray() As Integer

With PaymentMaster.lstDatabase
    For i = 0 To .ListCount - 1
        If .Selected(i) Then
            ReDim Preserve SlipArray(c)
            SlipArray(c) = .List(i)
            c = c + 1
        End If
    Next i
End With

For d = 0 To c - 1

    FarmerCode = SlipArray(d)

'copying information 

    Dim pd,ps As Worksheet
    
    Set pd = ThisWorkbook.Sheets("purchasedata")
    Set ps = ThisWorkbook.Sheets("paymentslip")
    
    ps.Range("B8:N23").ClearContents

    Dim a,lr,j,b As Integer

    With PaymentMaster
    
        a = CDate(.TextBox2.Value) - CDate(.TextBox1.Value)
        lr = pd.Range("B" & Rows.Count).End(xlUp).Row + 1
        ps.Range("I5") = CDate(.TextBox1.Value)
        ps.Range("L5") = CDate(.TextBox2.Value)
        ps.Range("C5") = FarmerCode
        
        For j = 0 To a
            For b = 2 To lr
                If CDate(.TextBox1.Value) + j = pd.Range("B" & b) And pd.Range("D" & b) = FarmerCode Then
                    ps.Range("B" & j + 8) = CDate(.TextBox1.Value) + j
                    If pd.Range("C" & b) = "Morning" Then
                        ps.Range("C" & j + 8) = pd.Range("E" & b)
                        ps.Range("D" & j + 8) = pd.Range("F" & b)
                        ps.Range("E" & j + 8) = pd.Range("G" & b)
                        ps.Range("F" & j + 8) = pd.Range("H" & b)
                        ps.Range("G" & j + 8) = pd.Range("I" & b)
                        ps.Range("H" & j + 8) = pd.Range("J" & b)
                    ElseIf pd.Range("C" & b) = "Evening" Then
                        ps.Range("I" & j + 8) = pd.Range("E" & b)
                        ps.Range("J" & j + 8) = pd.Range("F" & b)
                        ps.Range("K" & j + 8) = pd.Range("G" & b)
                        ps.Range("L" & j + 8) = pd.Range("H" & b)
                        ps.Range("M" & j + 8) = pd.Range("I" & b)
                        ps.Range("N" & j + 8) = pd.Range("J" & b)
                    End If
                End If
            Next b
        Next j
    
    End With
    
ThisWorkbook.Sheets("paymentslip").PrintPreview

Next d

End Sub

解决方法

无法存储打印预览的结果或将先前获得的多个打印预览合并到新的打印预览中。

认识到这一点，您可以在每一步使用Copy方法制作“ payslip”工作表的副本，并创建将所有副本合并在一起的打印预览。

为此，您可以将这些工作表的名称存储在array内，然后可以将具有这些工作表名称的数组传递给Sheets对象，以进行PrintPreview的操作一张以上。

请注意，这将生成许多工作表，因此我们需要确保代码在的开始时删除了那些较早的副本

在您的代码中，看起来像这样：

Sub SlipMacro2()

    'Getting customer code number

    Dim i,c,d As Long,FarmerCode As Integer
    Dim SlipArray() As Integer

    With PaymentMaster.lstDatabase
        For i = 0 To .ListCount - 1
            If .Selected(i) Then
                ReDim Preserve SlipArray(c)
                SlipArray(c) = .list(i)
                c = c + 1
            End If
        Next i
    End With

    For d = 0 To c - 1

        FarmerCode = SlipArray(d)

        'Copying information

        Dim pd,ps As Worksheet
    
        Set pd = ThisWorkbook.Sheets("purchasedata")
        Set ps = ThisWorkbook.Sheets("paymentslip")
    
        ps.Range("B8:N23").ClearContents

        Dim a,lr,j,b As Integer

        With PaymentMaster
    
            a = CDate(.TextBox2.Value) - CDate(.TextBox1.Value)
            lr = pd.Range("B" & Rows.Count).End(xlUp).Row + 1
            ps.Range("I5") = CDate(.TextBox1.Value)
            ps.Range("L5") = CDate(.TextBox2.Value)
            ps.Range("C5") = FarmerCode
        
            ''''''''''''''''''''''''''''''''''''''
            ' Delete older copies
            ''''''''''''''''''''''''''''''''''''''
            Dim ws As Worksheet
            For Each ws In ThisWorkbook.Worksheets
                If ws.Name Like ps.Name & " (*)" Then
                    Application.DisplayAlerts = False
                    ws.Delete
                    Application.DisplayAlerts = True
                End If
            Next

            ''''''''''''''''''''''''''''''''''''''
            ' Create list of sheets for the Print Preview
            ''''''''''''''''''''''''''''''''''''''
            Dim SheetsList() As Variant
            ReDim SheetsList(0 To a)
        
            For j = 0 To a
                For b = 2 To lr
                    If CDate(.TextBox1.Value) + j = pd.Range("B" & b) And pd.Range("D" & b) = FarmerCode Then
                        ps.Range("B" & j + 8) = CDate(.TextBox1.Value) + j
                        If pd.Range("C" & b) = "Morning" Then
                            ps.Range("C" & j + 8) = pd.Range("E" & b)
                            ps.Range("D" & j + 8) = pd.Range("F" & b)
                            ps.Range("E" & j + 8) = pd.Range("G" & b)
                            ps.Range("F" & j + 8) = pd.Range("H" & b)
                            ps.Range("G" & j + 8) = pd.Range("I" & b)
                            ps.Range("H" & j + 8) = pd.Range("J" & b)
                        ElseIf pd.Range("C" & b) = "Evening" Then
                            ps.Range("I" & j + 8) = pd.Range("E" & b)
                            ps.Range("J" & j + 8) = pd.Range("F" & b)
                            ps.Range("K" & j + 8) = pd.Range("G" & b)
                            ps.Range("L" & j + 8) = pd.Range("H" & b)
                            ps.Range("M" & j + 8) = pd.Range("I" & b)
                            ps.Range("N" & j + 8) = pd.Range("J" & b)
                        End If
                    End If
                Next b

                ''''''''''''''''''''''''''''''''''''''
                ' Make a copy of the sheet at the end of the workbook
                ''''''''''''''''''''''''''''''''''''''
                SheetsList(j) = CopySheetAtTheEnd(ps).Name
            
            Next j
    
        End With

        ''''''''''''''''''''''''''''''''''''''
        ' Pass the array to the Sheets object to get more than one sheet
        ''''''''''''''''''''''''''''''''''''''        
        ThisWorkbook.Sheets(SheetsList()).PrintPreview

    Next d

End Sub

Aslo确保包括以下功能：

Function CopySheetAtTheEnd(ByRef ws As Worksheet) As Worksheet
'This function is robust to the presence of hidden sheets
'Based on this answer: https://stackoverflow.com/a/24041228/5958842

    Dim wb As Workbook
    Set wb = ws.Parent
    Dim IsLastSheetVisible As Boolean
    
    With wb
        IsLastSheetVisible = .Sheets(.Sheets.Count).Visible
        .Sheets(Sheets.Count).Visible = True
        .Sheets(ws.Name).Copy AFTER:=.Sheets(Sheets.Count)
        Set CopySheetAtTheEnd = .Sheets(Sheets.Count)
        If Not IsLastSheetVisible Then .Sheets(Sheets.Count - 1).Visible = False
    End With

End Function

对不起，所有的麻烦，我找到了以下解决方法

Sub SlipMacro2()

Dim i,FarmerCode As Integer
Dim SlipArray() As String

With PaymentMaster.lstDatabase
    For i = 0 To .ListCount - 1
        If .Selected(i) Then
            ReDim Preserve SlipArray(c)
            SlipArray(c) = .List(i)
            c = c + 1
        End If
    Next i
End With

For d = 0 To c - 1

    FarmerCode = SlipArray(d)

    Dim pd,ps As Worksheet
    
    Set pd = ThisWorkbook.Sheets("purchasedata")
    Set ps = ThisWorkbook.Sheets("paymentslip")
    
    ps.Range("B8:N23").ClearContents

    Dim a,b As Integer

    With PaymentMaster
    
        a = CDate(.TextBox2.Value) - CDate(.TextBox1.Value)
        lr = pd.Range("B" & Rows.Count).End(xlUp).Row + 1
        ps.Range("I5") = CDate(.TextBox1.Value)
        ps.Range("L5") = CDate(.TextBox2.Value)
        ps.Range("C5") = FarmerCode
        
        For j = 0 To a
            For b = 2 To lr
                If CDate(.TextBox1.Value) + j = pd.Range("B" & b) And pd.Range("D" & b) = FarmerCode Then
                    ps.Range("B" & j + 8) = CDate(.TextBox1.Value) + j
                    If pd.Range("C" & b) = "Morning" Then
                        ps.Range("C" & j + 8) = pd.Range("E" & b)
                        ps.Range("D" & j + 8) = pd.Range("F" & b)
                        ps.Range("E" & j + 8) = pd.Range("G" & b)
                        ps.Range("F" & j + 8) = pd.Range("H" & b)
                        ps.Range("G" & j + 8) = pd.Range("I" & b)
                        ps.Range("H" & j + 8) = pd.Range("J" & b)
                    ElseIf pd.Range("C" & b) = "Evening" Then
                        ps.Range("I" & j + 8) = pd.Range("E" & b)
                        ps.Range("J" & j + 8) = pd.Range("F" & b)
                        ps.Range("K" & j + 8) = pd.Range("G" & b)
                        ps.Range("L" & j + 8) = pd.Range("H" & b)
                        ps.Range("M" & j + 8) = pd.Range("I" & b)
                        ps.Range("N" & j + 8) = pd.Range("J" & b)
                    End If
                End If
            Next b
        Next j
    
    End With
    
ps.Copy after:=ps
ActiveSheet.Name = FarmerCode

Next d

ThisWorkbook.Sheets(SlipArray()).PrintPreview
Application.DisplayAlerts = False
ThisWorkbook.Sheets(SlipArray()).Delete
Application.DisplayAlerts = True

End Sub

excel excel multipage preview preview printing printing vba