Excel~合并单元格自动调整行高

Excel 可以通过设置自动调整行高或列宽以使输入的内容完全显示出来，但是对于一些合并了的单元格，即使设置了自动行高或自动列宽，单元格却不会随内容的增多而自动调整单元格宽高。因为每次都需要手动调整行高或列宽比较麻烦，想着搜一下有没有相关的 VBA 代码，最终在 ExcelHome 上发现版主 ggmmlol 提供了相关代码，这里转载一下以备后查。

Workbook 代码

打开开发者工具，在 ThisWorkbook 中插入如下代码：

Public WithEvents ExcelApp As Excel.Application
Private tbx As Shape

Private Sub ExcelApp_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim sobj As Object, Rng As Range
    If Not KeyOn Then Exit Sub
    If Target.MergeCells Then                                                                      '如果是所选单元格为合并单元格
        Set myMergeArea = Target.Cells(1).MergeArea                                                '获取合并单元格所在区域
        If myMergeArea.Cells(1) = "" Then Exit Sub                                                 '合并单元格为空时跳出过程
        '保存合并单元格的位置、大小、及其字体的名字、大小
        With myMergeArea
            myMergeAreaAddress = .Address                                                          '获取合并单元格地址信息
            vtAlign = .VerticalAlignment                                                           '设置合并单元格对齐方式为垂直居中对齐
            wdth = .Next.Offset(, .Rows(1).Count).Left - .Left
            Debug.Print myMergeAreaAddress
            rc = .Rows.Count                                                                       '获取合并单元格行数
            myMergeAreaRowheights = ""
            For i = 1 To rc
                myMergeAreaRowheights = myMergeAreaRowheights & "," & .Rows(i).RowHeight           '记录合并单元格每行“历史”行高
            Next
            Set Rng = ThisWorkbook.Sheets(1).Range("A1")                                           '设置当前工作簿的第一个工作表的 A1 单元格为 Rng 对象
            cc = .Columns.Count                                                                    '获取合并单元格列数
            KeyOn = False
            .Copy Rng                                                                              '将合并单元格内容临时存放于 Rng 中
            KeyOn = True
            Rng.UnMerge                                                                            '设置 Rng 区域为非合并单元格
            Rng.WrapText = True                                                                    '设置 Rng 区域文本自动换行
            For i = 1 To cc
                cwd = cwd + .Cells(1, i).ColumnWidth                                               '计算合并单元格区域字符数（每个单元格0-255）
                wd = wd + .Cells(1, i).Width                                                       '计算合并单元格区域磅宽度（1磅 = 0.35毫米）
            Next
            Rng.ColumnWidth = cwd                                                                  '将合并单元格字符数宽度赋值给 Rng 列宽
            
            '计算 Rng 区域真实应为宽度
            Do
                ws = Rng.Width - wd                                                                '单元格之间默认线宽为 0.375 字符数
                If ws >= 0 Then Exit Do
                cwd = cwd - ws * DPI / 72 * 0.127                                                  '72是每英寸的Point个数，0.127毫米是1英寸的1/200。（1英寸 = 25.4毫米 ）
                Rng.ColumnWidth = cwd
            Loop
            Rng.EntireRow.AutoFit                                                                  '根据 Rng 列宽，通过自动换行获取行高
            ht = (Rng.RowHeight + IIf(rc > 5, 5, 2)) / rc                                          '计算合并单元格平均高度
            Repeat_MergeAreaRowsAutofit
        End With
        Application.OnUndo "撤销'合并单元格自动行高'操作", "Undo_MergeAreaRowsAutofit"
    End If
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    ThisWorkbook.Saved = True
    'Application.AddIns(Split(ThisWorkbook.Name, ".")(0)).Installed = False
End Sub
Private Sub Workbook_Open()
    Set ExcelApp = ThisWorkbook.Application
End Sub

代码主要用于打开文档时向 Excel 插入一个 Application 对象，具体代码都做了注释，看看即可。

模块代码

新建一个模块，在模块中插入如下代码：

Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const TWIPSPERINCH = 1440
#If Win64 And VBA7 Then
    Public Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
    Public Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Public Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
#Else
    Public Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
    Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Public Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
#End If

Public DPI
Public myMergeAreaAddress As String
Public myMergeAreaRowheights As String
Public ht As Single
Public vtAlign As Excel.Constants
Public WrapTxt As Boolean
Public KeyOn As Boolean

Function getDPI(bX As Boolean) As Integer  '获取屏幕分辨率
    Dim hDC As Long, RetVal As Long
    hDC = GetDC(0)
    If bX = True Then
        getDPI = GetDeviceCaps(hDC, LOGPIXELSX)
    Else
        getDPI = GetDeviceCaps(hDC, LOGPIXELSY)
    End If
    RetVal = ReleaseDC(0, hDC)
End Function

Sub Undo_MergeAreaRowsAutofit()
    With Range(myMergeAreaAddress)
       .VerticalAlignment = vtAlign
       rc = .Rows.Count
        rh = Split(myMergeAreaRowheights, ",")
        For i = 1 To rc
            .Rows(i).RowHeight = rh(i)
        Next
    End With
    Application.OnRepeat "恢复'合并单元格自动行高'操作", "Repeat_MergeAreaRowsAutofit"
End Sub

Sub Repeat_MergeAreaRowsAutofit()
    With Range(myMergeAreaAddress)
        .EntireRow.RowHeight = ht                                   '根据平均高度设置行高
        .VerticalAlignment = xlCenter                               '设置垂直方向居中对齐
        .WrapText = True                                            '设置自动换行
    End With
    Application.OnUndo "撤销'合并单元格自动行高'操作", "Undo_MergeAreaRowsAutofit"
End Sub

Sub 开关自动行高()
    KeyOn = Not KeyOn

    MsgBox "合并单元格自动行高功能已经" & IIf(KeyOn, "开启！", "关闭！")
    If Not KeyOn Then
        ThisWorkbook.Close
    ElseIf IsEmpty(DPI) Then
        DPI = getDPI(1)
    End If
End Sub