如何收集 vba 中 for 循环创建的所有打印预览？
How can I collect all print previews created from for loop in vba?
我有一个列表框，我想在单个打印预览中为所有选定的客户打印预览报告。 youtube 上有一个与此相关的视频 --> https://youtu.be/962Hd4akras ，如果您在单独的 sheet 上有数据，它给出了如何实现它的一些想法。但就我而言，我使用 for 循环来获取选定客户的数据。我正在一个接一个地收集数据并将其放入一个 sheet 中，在那里我完成了一些格式化。我的代码为每个选定的客户提供单独的打印预览。但我想要的是为所有客户获得组合打印预览（多页打印预览）。
这是我的代码。
Note:I 有固定工作sheet 以及打印区域。
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 方法制作 sheet“付款单”的副本，并创建包含所有这些副本的打印预览。
为此，您可以将 sheet 的名称存储在 array 中，然后您可以将带有 sheet 名称的数组传递给 Sheets 反对做一个 PrintPreview 多个 sheet.
请注意，这将生成许多 sheet，因此我们需要确保代码在
开始时删除那些较旧的副本
在您的代码中，它看起来像这样：
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
同时确保包含以下功能：
Function CopySheetAtTheEnd(ByRef ws As Worksheet) As Worksheet
'This function is robust to the presence of hidden sheets
'Based on this answer:
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, c, d As Long, 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, 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
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
我有一个列表框，我想在单个打印预览中为所有选定的客户打印预览报告。 youtube 上有一个与此相关的视频 --> https://youtu.be/962Hd4akras ，如果您在单独的 sheet 上有数据，它给出了如何实现它的一些想法。但就我而言，我使用 for 循环来获取选定客户的数据。我正在一个接一个地收集数据并将其放入一个 sheet 中，在那里我完成了一些格式化。我的代码为每个选定的客户提供单独的打印预览。但我想要的是为所有客户获得组合打印预览（多页打印预览）。 这是我的代码。 Note:I 有固定工作sheet 以及打印区域。
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 方法制作 sheet“付款单”的副本，并创建包含所有这些副本的打印预览。
为此，您可以将 sheet 的名称存储在 array 中，然后您可以将带有 sheet 名称的数组传递给 Sheets 反对做一个 PrintPreview 多个 sheet.
请注意，这将生成许多 sheet，因此我们需要确保代码在
开始时删除那些较旧的副本在您的代码中，它看起来像这样：
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
同时确保包含以下功能：
Function CopySheetAtTheEnd(ByRef ws As Worksheet) As Worksheet
'This function is robust to the presence of hidden sheets
'Based on this answer:
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, c, d As Long, 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, 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
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