Excel打印压字/VBA增加行高

> 最近遇到一些数据量大的Excel表格，普通视图正常，打印出现压字的情况。

![压字](/usr/uploads/2025/11/4263872849.png)

# 一、研究

1. 尝试自动行高但还是差了一点，经过多次测试我感觉还是出现在字体上，每种字体高度参差不齐，比如等线字体显示效果就比宋体好。但也不能遇到此现象上来就修改字体吧，毕竟有些文件的字体有格式要求。
2. 尝试导出不同DPI（72-600）的文件，甚至修改了Windows自带的缩放，但问题依旧。
3. 我能想到比较好的办法就是给每行增加一点高度，但行数多、高度不统一时，没办法全选批量修改。
4. 最后想到VBA宏，询问GPT各种调试，最终解了燃眉之急。![VBA宏](/usr/uploads/2025/11/3524814013.png)

[collapse status="false" title="IceYer宏.bas"]

```vbnet
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
```

[/collapse]

# 二、制作安装包

为了方便分享，继续让GPT写了本次的安装脚本，再配合WinRAR自解压实现双击安装。
PS：导入VBA宏至Excel个人宏工作簿

![安装](/usr/uploads/2025/11/3832093234.png)

![运行](/usr/uploads/2025/11/4033706120.png)

PS：若有的行压字有的行不压字，请切换至页面视图重新运行宏脚本。![页面布局](/usr/uploads/2025/11/84726483.png)

# 三、下载

[hide]

[button color="light" icon="" url="https://link.iceyer.cn:444/d/www.iceyer.cn/372/导入VBA宏至Excel个人宏工作簿.exe" type=""]导入VBA宏至Excel个人宏工作簿.exe[/button]

[/hide]

> 最近遇到一些数据量大的Excel表格，普通视图正常，打印出现压字的情况。

![压字](/usr/uploads/2025/11/4263872849.png)

# 一、研究

<div class="panel panel-default collapse-panel box-shadow-wrap-lg"><div class="panel-heading panel-collapse" data-toggle="collapse" data-target="#collapse-3f0feb71f625a787c3a4ad1fa274829717" aria-expanded="true"><div class="accordion-toggle"><span style="">IceYer宏.bas</span>
<i class="pull-right fontello icon-fw fontello-angle-right"></i>
</div>
</div>
<div class="panel-body collapse-panel-body">
<div id="collapse-3f0feb71f625a787c3a4ad1fa274829717" class="collapse collapse-content"><p></p>

```vbnet
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

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

Application.StatusBar = False
    Application.EnableEvents = True
    Application.ScreenUpdating = True

MsgBox "已完成自动行高调整，每行增加 " & padPt & " pt。", vbInformation

End Sub
```

# 二、制作安装包

为了方便分享，继续让GPT写了本次的安装脚本，再配合WinRAR自解压实现双击安装。
PS：导入VBA宏至Excel个人宏工作簿

![安装](/usr/uploads/2025/11/3832093234.png)

![运行](/usr/uploads/2025/11/4033706120.png)

PS：若有的行压字有的行不压字，请切换至页面视图重新运行宏脚本。![页面布局](/usr/uploads/2025/11/84726483.png)

# 三、下载

<div class="hideContent">此处内容需要评论回复后（审核通过）方可阅读。</div>

Last modification：December 18, 2025

喜欢我的文章吗？别忘了点赞或赞赏，让我知道创作的路上有你陪伴。

Excel打印压字/VBA增加行高

Leave a Comment Cancel reply
使用cookie技术保留您的个人信息以便您下次快速评论，继续评论表示您已同意该条款

群晖NAS Docker运行Clash与yacd

Home Assistant——HACS添加代理提升下载速度

CAD钢筋符号已替换tssdeng.shx字体，但还是显示问号？

便(垃)携(圾)主机——小米mix2s+ipad3屏幕+displaylink扩展坞！！！

记录一次显示器EDID文件解析

Home Assistant——云音乐ha_cloud_music（播放的不是对应的音乐？）

Go-CQHttp 氷叶机器人

PPT抽奖VBA实例

记录一次显示器EDID文件解析

WindowsDOC 第一个C# WPF程序

Excel打印压字/VBA增加行高

Leave a Comment Cancel reply 使用cookie技术保留您的个人信息以便您下次快速评论，继续评论表示您已同意该条款

Excel打印压字/VBA增加行高

Leave a Comment Cancel reply
使用cookie技术保留您的个人信息以便您下次快速评论，继续评论表示您已同意该条款