如何实现按列表名单顺序跨工作簿打印

15358300083

因工作需打印较多份表格，打印完需手工再整理，产生大量重复工作。想简化工作，实现按列表给出的名单，按顺序打印表格。

15358300083

打印机设为HP LaserJet M1005

15358300083

现有两个代码，不知道如何组装起来实现运行。

15358300083

1. Sub 打印_Click()
   
2. Range("B2").Select
   
3. d = Range("B2").Value
   
4. s = InputBox("请输入号：")
   
5. Windows(d & "装潢表.xls").Activate
   
6. Sheets("" & s & "").Select
   
7. Application.EnableEvents = False
   
8.     ActiveWindow.SelectedSheets.PrintOut From:=1, To:=2, Copies:=1, Preview:=False, ActivePrinter:="HP LaserJet M1005 Class Driver", PrintToFile:=False, Collate:=False, IgnorePrintAreas:=False
   
9.     Application.EnableEvents = True
   
10. Windows(d & "勘查表.xls").Activate
    
11. Application.EnableEvents = False
    
12.     ActiveWindow.SelectedSheets.PrintOut From:=1, To:=8, Copies:=1, Preview:=False, ActivePrinter:="HP LaserJet M1005 Class Driver", PrintToFile:=False, Collate:=False, IgnorePrintAreas:=False
    
13.     Application.EnableEvents = True
    
14.     Windows("正式报告.xls").Activate
    
15. 
    
16. End Sub

复制代码

1. Sub 批量复制表格并重命名()
   
2. 
   
3. Dim arr(), i, n, r
   
4. 
   
5. n = Worksheets("列表").UsedRange.Count - 1
   
6. ReDim arr(1 To n)
   
7. For i = 1 To n
   
8. arr(i) = Worksheets("列表").Cells(i + 1, 1)
   
9. Next
   
10. 
    
11. For r = 1 To UBound(arr)
    
12. Worksheets("模板").Copy after:=Worksheets(1 + r)
    
13. ActiveSheet.Name = arr(r)
    
14. Next
    
15. 
    
16. End Sub
    

复制代码

这两个如何拼凑能实现功能

3190496160

Sub 批量打印()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("打印名单")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "请输入打印名单！": End
    ar = .Range("a1:a" & r)
End With
lj = ThisWorkbook.Path & "\"
f = Dir(lj & "*.xls*")
Do While f <> ""
    If f <> ThisWorkbook.Name Then
        n = n + 1
        Set wb = Workbooks.Open(lj & f, 0)
    End If
f = Dir
Loop
For i = 2 To UBound(ar)
    d.RemoveAll
    If Trim(ar(i, 1)) <> "" Then
        mc = Trim(ar(i, 1))
        With ThisWorkbook
            For Each sh In .Sheets
                d(sh.Name) = ""
            Next sh
            If d.exists(Trim(ar(i, 1))) Then
                .Worksheets(mc).PrintOut From:=1, To:=1
            End If
        End With
        d.RemoveAll
        With Workbooks("计算表.xls")
            For Each sh In .Sheets
                d(sh.Name) = ""
            Next sh
            If d.exists(Trim(ar(i, 1))) Then
                .Worksheets(mc).PrintOut From:=1, To:=1
            End If
        End With
        d.RemoveAll
        With Workbooks("勘察表.xls")
            For Each sh In .Sheets
                d(sh.Name) = ""
            Next sh
            If d.exists(Trim(ar(i, 1))) Then
                .Worksheets(mc).PrintOut From:=1, To:=1
            End If
        End With
        d.RemoveAll
        With Workbooks("装潢表.xls")
            For Each sh In .Sheets
                d(sh.Name) = ""
            Next sh
            If d.exists(Trim(ar(i, 1))) Then
                .Worksheets(mc).PrintOut From:=1, To:=1
            End If
        End With
    End If
Next i
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

打印表格.rar (48.36 KB, 下载次数: 3)

2023-2-6 12:15 上传

点击文件名下载附件

3190496160

仅仅是一个初稿，一些细节为认真考虑，代码仅供参考

15358300083

3190496160 发表于 2023-2-6 12:14

十分感谢，相当流畅，完全可以实现所需功能。