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
附件使用方法
将附件另存为加载宏格式(.xlam),然后将其丢在EXCEL默认的加载宏文件夹下,最后在“开发工具”选项卡上点“加载项”按钮,在弹出的对话框中,把“合并单元格自动行高”勾选上就可以了。或者选择xlam 格式文件所在文件夹,手动加载亦可。
评论 抢沙发