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