使用VBA实现Word多表格单元格文本溢出时自动缩小字号

核心前提说明 #

表格单元格和文本框的溢出判断逻辑不通用：Word文本框可直接通过TextFrame2.TextRange.Overflowing属性判断溢出状态，但表格单元格未对外暴露该属性，无法直接套用文本框的调整方案，需要通过实际排版渲染的高度对比实现溢出判断。
本方案全程不修改单元格原有宽高、内边距设置，完全基于Word实际排版结果调整字号，适配Arial等任意字体，不需要提前按字符长度做字号映射。

实现逻辑 #

• 遍历文档内所有表格，定位到每个表格存储姓名的目标单元格，计算时自动排除单元格末尾默认的段落标记，避免高度计算误差
• 记录单元格绑定的固定行高值，全程不改动宽高相关参数
• 从预设的初始字号开始逐次下调1磅，每次调整后强制触发文档重排，拿到最新的内容实际渲染高度
• 对比内容实际渲染高度和单元格固定高度，当内容高度小于等于单元格可用高度时停止调整，保证显示的字号为不溢出前提下的最大值
• 设置字号下限，避免文字过小无法识别

完整VBA代码 #

Sub AdjustNameCellFontSize()
    '配置项，可根据自己的实际需求修改
    Const MIN_FONT_SIZE As Single = 6        '允许的最小字号（磅）
    Const INIT_FONT_SIZE As Single = 11      '姓名单元格原始字号（磅）
    Const HEIGHT_TOLERANCE As Single = 1     '高度容错值（磅），适配单元格默认内边距，溢出可适当调大
    
    Dim tbl As Table
    Dim targetCell As Cell
    Dim cellRng As Range
    Dim cellFixedHeight As Single
    Dim currentSize As Single
    Dim contentRealHeight As Single
    
    '关闭屏幕更新提升运行速度，100+表格也能快速处理
    Application.ScreenUpdating = False
    
    '遍历文档中所有表格
    For Each tbl In ActiveDocument.Tables
        '定位目标单元格：当前表格第1行第1列，如果姓名在其他位置修改此处的行列号即可
        Set targetCell = tbl.Cell(1, 1)
        Set cellRng = targetCell.Range
        '排除单元格末尾自带的段落标记，避免高度计算偏差
        cellRng.MoveEnd wdCharacter, -1
        
        '仅处理设置了固定行高的行
        If tbl.Rows(1).HeightRule = wdRowHeightExactly Then
            cellFixedHeight = tbl.Rows(1).Height
            currentSize = INIT_FONT_SIZE
            cellRng.Font.Size = currentSize
            
            '循环调整字号直到不溢出
            Do
                '强制重排文档，获取最新排版计算结果
                ActiveDocument.Repaginate
                '计算内容实际占用高度：内容最后一个字符的垂直位置 - 第一个字符的垂直位置
                contentRealHeight = cellRng.Characters.Last.Information(wdVerticalPositionRelativeToPage) - _
                                    cellRng.Characters.First.Information(wdVerticalPositionRelativeToPage)
                
                '内容高度小于单元格可用高度时停止调整
                If contentRealHeight <= cellFixedHeight - HEIGHT_TOLERANCE Then Exit Do
                
                '字号下调1磅
                currentSize = currentSize - 1
                '达到最小字号下限则停止调整
                If currentSize < MIN_FONT_SIZE Then Exit Do
                
                cellRng.Font.Size = currentSize
            Loop
        End If
    Next tbl
    
    '恢复屏幕更新
    Application.ScreenUpdating = True
    MsgBox "所有单元格字号调整完成！"
End Sub

使用方法 #

• 运行前务必备份原文档，在邮件合并完成生成最终Word文档后再运行脚本
• 按Alt+F11快捷键打开VBA编辑器
• 在左侧工程资源管理器中右键点击当前文档名称，依次选择「插入」-「模块」，将上述代码粘贴到弹出的模块代码窗口中
• 按F5键运行AdjustNameCellFontSize过程即可自动完成所有调整

调参说明 #

• 如果你的姓名单元格初始字号不是11磅，修改INIT_FONT_SIZE常量为实际使用的字号值即可
• 如果运行后仍有个别单元格出现溢出，将HEIGHT_TOLERANCE的值适当调大（比如改为1.5或2）即可
• 如果需要调整字号下限，修改MIN_FONT_SIZE的数值即可
• 如果姓名不在每个表格的第1行第1列，将tbl.Cell(1, 1)中的两个数字改为对应的行号、列号即可

内容的提问来源于stack exchange，提问作者user18621702