【原】VBA【代码】实用案例：批量打印，省心！根据打印模板循环打印，超过设定行数自动分页！

冷茶视界 2024-04-26 发布于江苏

展开全文

点【关于本公众号】了解一下，欢迎关注，谢谢！

快速浏览

实用案例

|日期控件 ||简单的收发存||收费管理系(Access改进版)|

|电子发票管理助手||电子发票登记系统(Access版)|

|文件合并 ||表格拆分 ||审计凭证抽查底稿|

|中医诊所收费系统(Excel版)||中医诊所收费系统(Access版)||银行对账单自动勾对|

|印章使用登记系统|

收费使用项目

|财务管理系统||工资薪金和年终奖个税筹划||新税法下工资表模版|

内容提要

批量打印|完整代码

1、在工作表“列表”里，命令按钮点击事件，显示用户窗体：

Private Sub CmdPrint_Click()    Usf_Print.ShowEnd Sub

2、在myModule里，确认继续自定义函数：

Function wContinue(Msg) As Boolean    '确认继续函数    Dim Config As Long    Dim a As Long    Config = vbYesNo + vbQuestion + vbDefaultButton2    Ans = MsgBox(Msg & Chr(10) & Chr(10) & "是(Y)继续?" & Chr(10) & Chr(10) & "否(N)退出！", Config)    wContinue = Ans = vbYesEnd Function

3、在用户窗体Usf_Print里，列表打印相关代码：

Dim arr()Dim iRowDim iColDim tbTitle()Dim ws As Worksheet, lastRow As Long, lastCol As IntegerDim dic As ObjectDim dkey As String, temp()Dim clsRG As New clsRanges
Private Sub CmdPrint_Click()    Dim t As Integer    Dim strOrder As String    With Me.LvProductList        For i = 1 To .ListItems.Count            If .ListItems(i).Checked Then                t = t + 1                strOrder = strOrder & .ListItems(i).SubItems(1) & "/"            End If        Next    End With    If t = 0 Then        MsgBox "未勾选任何记录！"        Exit Sub    End If    strOrder = Left(strOrder, Len(strOrder) - 1)    If Not wContinue("即将打印以下" & t & "条记录:" & Chr(10) & strOrder) Then Exit Sub    If Not Application.Dialogs(xlDialogPrinterSetup).Show Then Exit Sub    With Me.LvProductList        For i = 1 To .ListItems.Count            If .ListItems(i).Checked Then                dkey = .ListItems(i).SubItems(1)                Call printOrder(dkey)            End If        Next    End With    MsgBox "打印完成！"End Sub
Private Sub printOrder(orderNo As String)    Dim arrTitle(), pages As Integer, iRow As Integer    Dim rng As Range, maxRows As Integer    arrTitle = dic(orderNo)("title")    temp = dic(orderNo)("data")    iRow = UBound(temp, 2)    Set ws = ThisWorkbook.Sheets("打印页")    With ws        Set rng = clsRG.物料明细        clsRG.产品编码 = arrTitle(2)        clsRG.产品名称 = arrTitle(1)        clsRG.订单号 = orderNo        clsRG.计划数量 = arrTitle(3)        clsRG.日期 = arrTitle(0)        maxRows = rng.Rows.Count        pages = Application.WorksheetFunction.RoundUp(iRow / maxRows, 0)        For i = 1 To pages            clsRG.编号 = "第" & i & "页,共" & pages & "页"            clsRG.编号.ShrinkToFit = True            rng.ClearContents            With rng                For j = (i - 1) * maxRows + 1 To Application.WorksheetFunction.Min(iRow, i * maxRows)                    For k = 1 To UBound(temp)                        If k < 3 Then                            .Cells((j - 1) Mod maxRows + 1, k) = temp(k, j)                        Else                            .Cells((j - 1) Mod maxRows + 1, k + 1) = temp(k, j)                        End If                    Next                Next            End With            .PrintOut        Next    End WithEnd Sub
Private Sub CmdSearch_Click()    On Error Resume Next    Me.LvDetail.ListItems.Clear    Me.LvProductList.ListItems.Clear        Dim searchStr As String    Dim Lvitem As ListItem    iRow = UBound(arr)    iCol = 7        For i = 1 To iRow        For j = 1 To iCol            searchStr = searchStr & "|" & arr(i, j)        Next        If InStr(1, searchStr, Me.TextBox1.Value, 1) Then            Set Lvitem = Me.LvProductList.ListItems.Add            Lvitem.Text = Format(arr(i, 1), "YYYY/MM/DD")            For j = 2 To 7                Lvitem.SubItems(j - 1) = arr(i, j)            Next        End If        searchStr = ""    NextEnd Sub
Private Sub CmdSelectAll_Click()    With Me.LvProductList        If Me.CmdSelectAll.Caption = "全选" Then            For i = 1 To .ListItems.Count                .ListItems(i).Checked = True            Next            Me.CmdSelectAll.Caption = "全消"            Me.CmdSelectAll.BackColor = RGB(176, 224, 230)                    Else            For i = 1 To .ListItems.Count                .ListItems(i).Checked = False            Next            Me.CmdSelectAll.Caption = "全选"            Me.CmdSelectAll.BackColor = RGB(143, 188, 143)                    End If    End WithEnd Sub
Private Sub UserForm_Activate()    'On Error Resume Next    Dim Lvitem As ListItem    Me.CmdSelectAll.Visible = True    Me.CmdSelectAll.BackColor = RGB(143, 188, 143)    Me.CmdPrint.Visible = True    Me.Caption = "生产领料单打印"    Set dic = CreateObject("Scripting.Dictionary")    Set ws = ThisWorkbook.Sheets("列表")    With ws        lastRow = .UsedRange.Rows.Count        lastCol = .UsedRange.Columns.Count        arr = .Range(.Cells(2, 1), .Cells(lastRow, lastCol))        tbTitle = .Range(.Cells(1, 1), .Cells(1, lastCol)).Value    End With    For i = 1 To 8        With Me.LvProductList              .ColumnHeaders.Add , , tbTitle(1, i), 70         End With    Next    With Me.LvDetail        .View = lvwReport                        'listview控件的显示外观        .Gridlines = True                        '是否有表格线，True有表格线        '.Sorted = True        '.CheckBoxes = True        .LabelEdit = lvwManual        .FullRowSelect = True        .ForeColor = vbBlue    End With    With Me.LvProductList        .View = lvwReport                        'listview控件的显示外观        .Gridlines = True                        '是否有表格线，True有表格线        .Sorted = True        .CheckBoxes = True        .LabelEdit = lvwManual        .FullRowSelect = True            End With    iRow = UBound(arr)    iCol = UBound(arr, 2)    Me.LvProductList.ListItems.Clear    For i = 1 To iRow        If arr(i, 2) <> "" Then            dkey = arr(i, 2)            Set Lvitem = Me.LvProductList.ListItems.Add            Lvitem.Text = Format(arr(i, 1), "YYYY/MM/DD")            For j = 2 To 7                Lvitem.SubItems(j - 1) = arr(i, j)            Next        End If        If Not dic.exists(dkey) Then            dic.Add dkey, CreateObject("Scripting.Dictionary")            dic(dkey).Add "title", Array(arr(i, 1), arr(i, 3), arr(i, 4), arr(i, 5))            k = 1            ReDim temp(1 To 4, 1 To 1)            temp(1, k) = arr(i, 11)            temp(2, k) = arr(i, 12)            temp(3, k) = arr(i, 13)            temp(4, k) = arr(i, 14)            dic(dkey).Add "data", temp        Else            temp = dic(dkey)("data")            k = UBound(temp, 2) + 1            ReDim Preserve temp(1 To 4, 1 To k)            temp(1, k) = arr(i, 11)            temp(2, k) = arr(i, 12)            temp(3, k) = arr(i, 13)            temp(4, k) = arr(i, 14)            dic(dkey)("data") = temp        End If    Next    For i = 11 To 14        With Me.LvDetail            .ColumnHeaders.Add , , tbTitle(1, i), 70        End With    NextEnd Sub
Private Sub LvProductList_ItemClick(ByVal Item As MSComctlLib.ListItem)    Dim temp(), Lvitem As ListItem    dkey = Me.LvProductList.SelectedItem.SubItems(1)    temp = dic(dkey)("data")    With Me.LvDetail        .ListItems.Clear        For i = 1 To UBound(temp, 2)            Set Lvitem = .ListItems.Add            With Lvitem                .Text = temp(1, i)                For j = 2 To UBound(temp)                    .SubItems(j - 1) = temp(j, i)                Next            End With        Next    End WithEnd Sub

Private Sub Cmd_Exit_Click()    Unload MeEnd Sub

4、在类模块clsRange里，把一些Range加入类模块，方便引用：

Private ws As WorksheetPrivate Sub Class_Initialize()    Set ws = ThisWorkbook.Worksheets("打印页")End Sub
Public Property Get 日期() As Range    Set 日期 = ws.Range("G3")End PropertyPublic Property Get 订单号() As Range    Set 订单号 = ws.Range("I2")End Property
Public Property Get 产品编码() As Range    Set 产品编码 = ws.Range("B3")End Property
Public Property Get 产品名称() As Range    Set 产品名称 = ws.Range("B4")End Property
Public Property Get 计划数量() As Range    Set 计划数量 = ws.Range("E4")End PropertyPublic Property Get 编号() As Range    Set 编号 = ws.Range("K2")End Property
Public Property Get 物料明细() As Range    Set 物料明细 = ws.Range("A7:E14")End Property
Public Sub clearData()     日期 = ""     订单号 = ""     产品编码 = ""     产品名称 = ""     计划数量 = ""     编号 = ""     物料明细 = ""End Sub