EXCEL根据类别分页预览或者直接生成PDF

vbscript 复制代码
Sub PrintByCategoryWithOptions_SilentMode()
    Dim ws As Worksheet
    Dim dict As Object
    Dim key As Variant
    Dim lastRow As Long, i As Long
    Dim categoryColumn As Long
    Dim counter As Long
    Dim response As VbMsgBoxResult
    Dim outputMode As String
    Dim savePath As String
    Dim pdfFileName As String
    
    ' *************** 用户可修改参数 ***************
    Set ws = ThisWorkbook.Sheets("退款明细")  ' 工作表名
    categoryColumn = 3                        ' 分类列号（C列=3）
    Const titleRows As Long = 4               ' 标题行数（1-4行）
    Const lastCol As String = "J"             ' 最后一列字母
    ' *********************************************
    
    lastRow = ws.Cells(ws.Rows.Count, categoryColumn).End(xlUp).Row
    
    ' 创建字典存储分类信息
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 扫描所有分类并记录行范围
    Dim currentCategory As String
    Dim startRow As Long, endRow As Long
    Dim isNewCategory As Boolean
    
    startRow = titleRows + 1
    currentCategory = CStr(ws.Cells(startRow, categoryColumn).Value)
    
    For i = startRow To lastRow
        isNewCategory = (CStr(ws.Cells(i, categoryColumn).Value) <> currentCategory)
        
        If isNewCategory Or i = lastRow Then
            endRow = IIf(i = lastRow And Not isNewCategory, i, i - 1)
            
            If Not dict.Exists(currentCategory) And currentCategory <> "" Then
                dict.Add currentCategory, Array(startRow, endRow)
            End If
            
            If isNewCategory Then
                currentCategory = CStr(ws.Cells(i, categoryColumn).Value)
                startRow = i
            End If
        End If
    Next i
    
    ' 增强的输出模式选择
    response = Application.InputBox( _
        "请选择操作方式：" & vbCrLf & vbCrLf & _
        "1 - 打印预览（逐个查看）" & vbCrLf & _
        "2 - 生成PDF（逐个提示）" & vbCrLf & _
        "3 - 批量生成PDF（无提示）" & vbCrLf & vbCrLf & _
        "请输入数字选项 (1-3):", _
        "输出模式选择", "3", Type:=1)
    
    ' 处理用户选择
    If response = False Then Exit Sub  ' 用户取消
    
    Select Case response
        Case 1: outputMode = "PREVIEW"
        Case 2: outputMode = "PDF_PROMPT"
        Case 3: outputMode = "PDF_SILENT"
        Case Else
            MsgBox "无效选项，操作已取消", vbExclamation
            Exit Sub
    End Select
    
    ' PDF模式获取保存路径
    If outputMode Like "PDF*" Then
        savePath = BrowseForFolder("选择PDF保存位置")
        If savePath = "" Then Exit Sub
    End If
    
    ' 关闭屏幕更新加快速度
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    
    ' 备份原始设置
    Dim originalPrintArea As String
    originalPrintArea = ws.PageSetup.PrintArea
    
    ' 记录开始时间
    Dim startTime As Double
    startTime = Timer
    
    ' 按顺序处理每个分类
    Dim categories() As Variant
    categories = dict.keys
    
    For counter = 0 To dict.Count - 1
        key = categories(counter)
        Dim rowRange() As Variant
        rowRange = dict(key)
        startRow = rowRange(0)
        endRow = rowRange(1)
        
        ' 计算打印区域
        Dim printArea As String
        printArea = "$A$1:$" & lastCol & "$" & endRow
        
        ' 隐藏非当前分类的行
        HideNonCurrentRows ws, startRow, endRow, titleRows, lastRow
        
        ' 设置打印区域
        ws.PageSetup.PrintArea = printArea
        
        ' 根据模式执行操作
        Select Case outputMode
            Case "PREVIEW"
                ' 预览前提示信息
                Dim previewMsg As String
                previewMsg = "正在预览类别: " & key & vbCrLf & _
                             "(" & (counter + 1) & "/" & dict.Count & ")" & vbCrLf & _
                             "数据行范围: " & startRow & " - " & endRow & vbCrLf & _
                             "打印区域: A1:" & lastCol & endRow
                
                MsgBox previewMsg, vbInformation, "准备预览"
                ws.PrintPreview
                
                ' 预览后询问
                If MsgBox("类别: " & key & " 预览完成" & vbCrLf & _
                          "是否继续下一个类别？", vbYesNo + vbQuestion) = vbNo Then Exit For
                
            Case "PDF_PROMPT"
                ' 生成前提示信息
                Dim pdfMsg As String
                pdfMsg = "正在生成: " & key & vbCrLf & _
                         "(" & (counter + 1) & "/" & dict.Count & ")" & vbCrLf & _
                         "数据行范围: " & startRow & " - " & endRow
                
                MsgBox pdfMsg, vbInformation, "PDF生成中"
                
                ' 生成PDF文件
                pdfFileName = CleanFileName(key & "") & ".pdf"
                ws.ExportAsFixedFormat _
                    Type:=xlTypePDF, _
                    Filename:=savePath & pdfFileName, _
                    Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, _
                    IgnorePrintAreas:=False
                
            Case "PDF_SILENT"
                ' 静默模式 - 仅更新状态栏
                Application.StatusBar = "正在批量生成PDF (" & (counter + 1) & "/" & dict.Count & "): " & key
                
                ' 生成PDF文件
                pdfFileName = CleanFileName(key & "") & ".pdf"
                ws.ExportAsFixedFormat _
                    Type:=xlTypePDF, _
                    Filename:=savePath & pdfFileName, _
                    Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, _
                    IgnorePrintAreas:=False
        End Select
        
        ' 恢复所有行的可见性
        ws.Rows.Hidden = False
    Next counter
    
    ' 计算耗时
    Dim elapsedTime As Double
    elapsedTime = Round(Timer - startTime, 2)
    
    ' 恢复原始设置
    ws.PageSetup.PrintArea = originalPrintArea
    ws.Rows.Hidden = False
    Application.StatusBar = False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    
    ' 完成提示
    Dim msg As String
    msg = "操作完成！" & vbCrLf & "共处理 " & dict.Count & " 个类别" & vbCrLf & _
          "耗时: " & elapsedTime & " 秒"
    
    If outputMode Like "PDF*" Then
        msg = msg & vbCrLf & "PDF保存到: " & savePath
        
        ' 完成后打开保存文件夹
        If MsgBox(msg & vbCrLf & vbCrLf & "是否打开保存文件夹？", vbQuestion + vbYesNo, "操作完成") = vbYes Then
            Shell "explorer.exe """ & savePath & """", vbNormalFocus
        End If
    Else
        MsgBox msg, vbInformation, "报告"
    End If
End Sub

' 辅助函数：隐藏非当前分类的行
Sub HideNonCurrentRows(ws As Worksheet, startRow As Long, endRow As Long, titleRows As Long, lastRow As Long)
    ws.Rows.Hidden = False
    If titleRows + 1 < startRow Then
        ws.Rows(titleRows + 1 & ":" & startRow - 1).Hidden = True
    End If
    If endRow < lastRow Then
        ws.Rows(endRow + 1 & ":" & lastRow).Hidden = True
    End If
End Sub

Function CleanFileName(str As String) As String
    Dim illegalChars As String
    illegalChars = "\/:*?""<>|"
    CleanFileName = str
    For i = 1 To Len(illegalChars)
        CleanFileName = Replace(CleanFileName, Mid(illegalChars, i, 1), "_")
    Next i
End Function

Function BrowseForFolder(title As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = title
        If .Show <> -1 Then Exit Function
        BrowseForFolder = .SelectedItems(1)
        If Right(BrowseForFolder, 1) <> "\" Then BrowseForFolder = BrowseForFolder & "\"
    End With
End Function
使用方法：运行宏，粘贴代码。

请选择操作方式：
1 - 打印预览（逐个查看）
2 - 生成PDF（逐个提示）
3 - 批量生成PDF（无提示）
请输入数字选项 (1-3):
优势：

高效处理：
- 静默模式下可一次性处理数百个分类
- 无需人工干预，适合批量操作
灵活选择：
- 根据需求选择不同详细程度的模式
- 调试时用预览模式，日常操作用静默模式
用户体验：
- 完成后可直接打开保存文件夹
- 显示处理时间便于性能评估
- 状态栏进度反馈让用户了解运行状态