ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 EH云课堂直播课程免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 11559|回复: 75

[原创] 合并单元格自动调整行高小工具【加载宏】 更新2018-1-4

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2018-1-3 17:16 | 显示全部楼层 |阅读模式
本帖最后由 ggmmlol 于 2018-1-4 15:20 编辑

EXCEL单元格格式设置中的“自动调整行高”功能,对于合并单元格并不适合。
手动进行调整的话,可以用一个文本框的自动适合文字的设置,来得到合适的总高度,然后把这个总高度按合并单元格的行数进行均分,以此设置它们的行高。
但是,上述手动 操 作效率很低,如果表格中的合并单元格很多的话,那就会非常麻 烦。

在“以人为本”的思想为指导下,这种麻 烦 事,还是交给电脑来做吧!

附件使用方法:很简单的,
      把附件中的宏工作薄用EXCEL打开,再另存为 加载宏 格式(后缀名为.xlam),保存在EXCEL默认的加载宏文件夹下,然后在“开发工具”选项卡上点“加载项”按钮,在弹出的对话框中,把“合并单元格自动行高”勾选上就可以了。
      当你在合并单元格中编辑完成切换到其它单元格时,该程序就会自动运行。无论合并单元格字体的名称、大小是什么,它都能完成任务。

更新内容:
1、程序运行过程中,不再在当前的活动工作薄中添加、删除文本框和其它任何对象,以免影响到活动工作薄中的文本框命名。需要得到合并单元格最合适的行高时,直接使用预置于加载宏工作薄内的文本框,在对用户无任何打扰的情况下完成任务,做到“随风潜入夜,润物细无声”。
2、直接提供做好的加载宏。

模块1:

  1. Public myMergeAreaAddress As String
  2. Public myMergeAreaRowheights As String
  3. Public ht As Single
  4. Public vtAlign As Excel.Constants
  5. Public WrapTxt As Boolean
  6. Sub Undo_MergeAreaRowsAutofit()
  7.     With Range(myMergeAreaAddress)
  8.        .VerticalAlignment = vtAlign
  9.        rc = .Rows.Count
  10.         rh = Split(myMergeAreaRowheights, ",")
  11.         For i = 1 To rc
  12.             .Rows(i).RowHeight = rh(i)
  13.         Next
  14.     End With
  15.     Application.OnRepeat "恢复'合并单元格自动行高'操作", "Repeat_MergeAreaRowsAutofit"
  16. End Sub

  17. Sub Repeat_MergeAreaRowsAutofit()
  18.     With Range(myMergeAreaAddress)
  19.         .EntireRow.RowHeight = ht '   按平均高度设置行高
  20.         .VerticalAlignment = xlCenter '垂直方向居中对齐
  21.         .WrapText = True
  22.     End With
  23.     Application.OnUndo "撤销'合并单元格自动行高'操作", "Undo_MergeAreaRowsAutofit"
  24. End Sub
复制代码

ThisWorkbook模块:
  1. Public WithEvents ExcelApp As Excel.Application
  2. Private tbx As Shape

  3. Private Sub ExcelApp_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  4.     Dim tbx As Shape, sobj As Object
  5.     If Target.MergeCells Then '如果是合并单元格
  6.         Set myMergeArea = Target.Cells(1).MergeArea
  7.         With myMergeArea '           '保存合并单元格的位置、大小、及其字体的名字、大小
  8.             myMergeAreaAddress = .Address '地址
  9.             vtAlign = .VerticalAlignment '竖直对齐方式
  10.             Debug.Print .WrapText
  11.             txt = .Cells(1).Text
  12.             fn = .Font.Name
  13.             fs = .Font.Size
  14.             lft = .Left
  15.             wdth = .Next.Offset(, .Rows(1).Count).Left - .Left
  16.             rc = .Rows.Count
  17.             For i = 1 To rc
  18.                 myMergeAreaRowheights = myMergeAreaRowheights & "," & .Rows(i).RowHeight '记录“历史”行高
  19.             Next
  20.             Set sobj = tbx.TextFrame2.TextRange
  21.             With sobj '设置文本框
  22.                 .Parent.AutoSize = False
  23.                 .Parent.WordWrap = True
  24.                 .Font.Name = fn
  25.                 .Font.Size = fs
  26.                 .Text = txt
  27.             End With
  28.             With tbx
  29.                 .Width = wdth
  30.                 ht = tbx.Height / rc  '计算平均高度
  31.             End With
  32.             Repeat_MergeAreaRowsAutofit
  33.         End With
  34.         Application.OnUndo "撤销'合并单元格自动行高'操作", "Undo_MergeAreaRowsAutofit"
  35.         Application.OnRepeat "恢复'合并单元格自动行高'操作", "Repeat_MergeAreaRowsAutofit"
  36.     End If
  37. End Sub

  38. Private Sub Workbook_Open()
  39.     Set ExcelApp = ThisWorkbook.Application
  40.     Set tbx = ThisWorkbook.Sheets(1).Shapes("TextBox")'文本框预置于加载宏工作薄内,以变量加以引用。
  41. End Sub
复制代码



评分

参与人数 4鲜花 +7 收起 理由
zzqianlong + 2 优秀作品
zhy9086 + 2 太强大了
timgun + 1
gta + 2 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-1-13 11:55 | 显示全部楼层
本帖最后由 ggmmlol 于 2018-1-13 18:28 编辑

合并单元格自动行高.rar (19.72 KB, 下载次数: 1232)

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-1-3 18:35 | 显示全部楼层
本帖最后由 ggmmlol 于 2018-1-4 14:51 编辑

合并单元格自动行高.rar (17.66 KB, 下载次数: 553)

评分

参与人数 2财富 +20 鲜花 +2 收起 理由
沧海一声笑NEW2 + 2 优秀作品
lsc900707 + 20 值得肯定

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-1-4 16:32 | 显示全部楼层
本帖最后由 ggmmlol 于 2018-1-4 16:34 编辑

关于加载宏文件的使用,这里简单介绍一下:
复制以下内容,按 Windows键+R键,打开“运行”对话框,按Ctrl+V粘贴进去,点确定,就打开了EXCEL的加载宏默认文件夹,这晨,把解压出来的加载宏文件剪切或复制到这个文件夹里。然后在EXCEL的“开发工具”选项卡中,点“加载项”按钮,勾选这个加载宏的名字,再点“确定”之后,就可以了。

  1. %AppData%\Microsoft\AddIns\
复制代码



捕获.PNG

TA的精华主题

TA的得分主题

发表于 2018-1-10 07:44 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2018-1-13 16:54 | 显示全部楼层
厉害了,这个功能非常实用,赞一个。

TA的精华主题

TA的得分主题

发表于 2018-1-13 17:10 | 显示全部楼层
ggmmlol 发表于 2018-1-13 11:55
2018-1-13再次更新。
1、添加开关功能:
   由于是自动宏,避免干扰正常使用,添加开关功能。默认 ...

代码不能在2016上运行啊。
立uuuuuuuuuuuuuu.png

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-1-13 19:22 | 显示全部楼层
anymole 发表于 2018-1-13 17:10
代码不能在2016上运行啊。

谢谢反馈。
64位EXCEL中,在VBA里调用32位的API时,需要 在Declare 后面添加 一个关键词 PtrSafe。

你可以自己添加,也可以重新下载5楼的附件(此附件已经更新,添加了条件编译语句,现在也可以在64位Excel中使用了)。

TA的精华主题

TA的得分主题

发表于 2018-1-31 22:28 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2018-2-1 17:34 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

最新热点上一条 /1 下一条

关注官方微信,高效办公专列,每天发车

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2020-2-26 13:25 , Processed in 0.410828 second(s), 20 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表