最近遇到一些数据量大的Excel表格，普通视图正常，打印出现压字的情况。
一、研究
- 尝试自动行高但还是差了一点，经过多次测试我感觉还是出现在字体上，每种字体高度参差不齐，比如等线字体显示效果就比宋体好。但也不能遇到此现象上来就修改字体吧，毕竟有些文件的字体有格式要求。
- 尝试导出不同DPI（72-600）的文件，甚至修改了Windows自带的缩放，但问题依旧。
- 我能想到比较好的办法就是给每行增加一点高度，但行数多、高度不统一时，没办法全选批量修改。
- 最后想到VBA宏，询问GPT各种调试，最终解了燃眉之急。
IceYer宏.bas
Attribute VB_Name = "IceYer宏"
Sub Excel压字调整高度()
'
' Excel压字调整高度 宏
' 在自动识别行高基础上增加指定高度，可以有效解决压字情况。
'
Dim sht As Worksheet, r As Range
Dim padPt As Double
Dim totalRows As Long, i As Long, stepCount As Long
Dim userInput As Variant
'=== 让用户输入行高加值 ===
userInput = InputBox("请输入每行额外增加的高度（单位：pt）" & vbCrLf & _
"（按“取消”可中止执行）", _
"调整行高", 8.504)
If StrPtr(userInput) = 0 Then Exit Sub ' 取消直接退出
If IsNumeric(userInput) Then
padPt = CDbl(userInput)
Else
padPt = 0
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.StatusBar = "正在计算，请稍候..."
'=== 主体逻辑 ===
For Each sht In ActiveWindow.SelectedSheets
With sht.UsedRange
.WrapText = True
.EntireRow.AutoFit
totalRows = .Rows.Count
stepCount = Application.Max(1, totalRows \ 100) ' 每1%刷新一次状态栏
For i = 1 To totalRows
If .Rows(i).RowHeight > 0 Then
.Rows(i).RowHeight = .Rows(i).RowHeight + padPt
End If
' 每隔若干行刷新进度提示
If i Mod stepCount = 0 Then
Application.StatusBar = "正在调整行高：" & _
Format(i / totalRows, "0%") & " 完成"
DoEvents ' 防止假死
End If
Next i
End With
Next sht
Application.StatusBar = False
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "已完成自动行高调整，每行增加 " & padPt & " pt。", vbInformation
End Sub
二、制作安装包
为了方便分享，继续让GPT写了本次的安装脚本，再配合WinRAR自解压实现双击安装。
PS：若有的行压字有的行不压字，请切换至页面视图重新运行宏脚本。
三、下载
此处内容需要评论回复后（审核通过）方可阅读。