ExecelVBA批量打印文件夹有文件并设置打印为一页数

Execel VBA批量打印文件夹中的所有文件，并设置打印为一页数

【问题】

在工作中我们要打印文件夹中所有文件，如果每个文件打开--输入打印份数--打印--关闭，再来打开--输入打印份数--打印--关闭，如果文件少还可以， 如果文件多你会累S,

所以就想能不能一次打印完成。

于是想了一下，设计一个吧

本程序按键后--弹出文件夹选择框--选择文件夹--确定，就可以批量打印啦

【代码】

代码语言：javascript复制

'------选择文件夹批量打印一式x份---------------------------
Sub 批量打印设置copies()
    Dim lj, wb As Workbook
    Set objShell = CreateObject("Shell.Application")
    path0 = ThisWorkbook.Path & ""
    mypages = Range("B1").Value
    Set objFolder = objShell.BrowseForFolder(0, "选择文件夹", 0, path0)
    If objFolder Is Nothing Then
        MsgBox "未选择文件夹"
        Exit Sub
    End If
    lj = objFolder.self.Path
    If Right(lj, 1) <> "" Then
        lj = lj & ""
    End If
    Set objFolder = Nothing
    Set objShell = Nothing
    myFile = Dir(lj & "*.xls*")
    While myFile <> ""
        Set wb = Workbooks.Open(lj & myFile)
         wb.Worksheets(1).PrintOut Copies:=mypages
        wb.Close False
        myFile = Dir
    Wend
End Sub

【问题】问题又来了，因为文件有多个工作表，且要求工作表所有的工作表要打印为一页数。那怎么办。

经过思考。又解决了

【代码】

代码语言：javascript复制

Sub 设置内容打印为一页()
    Dim lj, wb As Workbook, 打印页数 As Integer, this_sht As Worksheet, sh As Worksheet
    
    Set objShell = CreateObject("Shell.Application")
    path0 = ThisWorkbook.Path & ""
    mypages = Range("B1").Value
    Set objFolder = objShell.BrowseForFolder(0, "选择文件夹", 0, path0)
    If objFolder Is Nothing Then
        MsgBox "未选择文件夹"
        Exit Sub
    End If
    lj = objFolder.self.Path
    If Right(lj, 1) <> "" Then
        lj = lj & ""
    End If
    Set objFolder = Nothing
    Set objShell = Nothing
    Application.ScreenUpdating = False '关闭屏幕刷新
    Application.DisplayAlerts = False '关闭提示
    myFile = Dir(lj & "*.xls*")
    While myFile <> ""
        Set wb = Workbooks.Open(lj & myFile)
            With wb
                For Each sh In wb.Worksheets
                    打印页数 = sh.PageSetup.Pages.Count 'ExecuteExcel4Macro("Get.Document(50)")
'                    Debug.Print "打印页数="; 打印页数
                    If 打印页数 > 1 Then
                        With sh.PageSetup
                              .PrintArea = sh.UsedRange.Address
                              .Zoom = False
                              .FitToPagesWide = 1
                              .FitToPagesTall = 1
                              Debug.Print ".Pages.Count="; .Pages.Count
                        End With
                    End If
                Next

             End With
             wb.Save
             wb.Close
        myFile = Dir
    Wend
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

本程序，能不用逐个打开文件的情况下，把文件夹中的所有文件所有工作表，设置打印为一页。

只要我们把两个程序整合就一起就可以完成：批量打印文件夹中的所有文件所有工作表，按一式X份的方式打印。一键---喝杯水---等一会再来打印机处拿你要的东西。哈哈

设置前

设置后

vba 程序 工作

0 人点赞