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

ggmmlol · 发表于 2018-1-3 17:16

本帖最后由 ggmmlol 于 2018-1-4 15:20 编辑

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

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

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

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

模块1：

Public myMergeAreaAddress As String
Public myMergeAreaRowheights As String
Public ht As Single
Public vtAlign As Excel.Constants
Public WrapTxt As Boolean
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

复制代码

ThisWorkbook模块：

Public WithEvents ExcelApp As Excel.Application
Private tbx As Shape
Private Sub ExcelApp_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim tbx As Shape, sobj As Object
If Target.MergeCells Then '如果是合并单元格
Set myMergeArea = Target.Cells(1).MergeArea
With myMergeArea ' '保存合并单元格的位置、大小、及其字体的名字、大小
myMergeAreaAddress = .Address '地址
vtAlign = .VerticalAlignment '竖直对齐方式
Debug.Print .WrapText
txt = .Cells(1).Text
fn = .Font.Name
fs = .Font.Size
lft = .Left
wdth = .Next.Offset(, .Rows(1).Count).Left - .Left
rc = .Rows.Count
For i = 1 To rc
myMergeAreaRowheights = myMergeAreaRowheights & "," & .Rows(i).RowHeight '记录“历史”行高
Next
Set sobj = tbx.TextFrame2.TextRange
With sobj '设置文本框
.Parent.AutoSize = False
.Parent.WordWrap = True
.Font.Name = fn
.Font.Size = fs
.Text = txt
End With
With tbx
.Width = wdth
ht = tbx.Height / rc '计算平均高度
End With
Repeat_MergeAreaRowsAutofit
End With
Application.OnUndo "撤销'合并单元格自动行高'操作", "Undo_MergeAreaRowsAutofit"
Application.OnRepeat "恢复'合并单元格自动行高'操作", "Repeat_MergeAreaRowsAutofit"
End If
End Sub
Private Sub Workbook_Open()
Set ExcelApp = ThisWorkbook.Application
Set tbx = ThisWorkbook.Sheets(1).Shapes("TextBox")'文本框预置于加载宏工作薄内，以变量加以引用。
End Sub

复制代码

ggmmlol · 发表于 2018-1-13 11:55

本帖最后由 ggmmlol 于 2018-1-13 18:28 编辑

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

2018-1-13再次更新。
1、添加开关功能：
由于是自动宏，为避免干扰正常使用，添加开关功能。默认是关闭状态，需要时可以随时切换。
2、添加自动从加载项中移除功能：
此功能让本加载宏按需加载。避免每次打开EXCEL时，都自动加载本宏。
3、修正小错误：上一版本，当合并单元格中的字符存在多个不同字体或字号时，程序运行出错。

ggmmlol · 发表于 2018-1-3 18:35

本帖最后由 ggmmlol 于 2018-1-4 14:51 编辑

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

补充内容 (2018-1-23 13:56):
最新附件在5楼。（已经置顶于1楼之下）

ggmmlol · 发表于 2018-1-4 16:32

本帖最后由 ggmmlol 于 2018-1-4 16:34 编辑

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

%AppData%\Microsoft\AddIns\

复制代码

df5ayc · 发表于 2018-1-10 07:44

谢谢，非常棒的功能

baojun026 · 发表于 2018-1-13 16:54

厉害了，这个功能非常实用，赞一个。

anymole · 发表于 2018-1-13 17:10

ggmmlol 发表于 2018-1-13 11:55
2018-1-13再次更新。
1、添加开关功能：
由于是自动宏，避免干扰正常使用，添加开关功能。默认 ...

代码不能在2016上运行啊。

ggmmlol · 发表于 2018-1-13 19:22

anymole 发表于 2018-1-13 17:10
代码不能在2016上运行啊。

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

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

有杕之杜 · 发表于 2018-1-31 22:28

很好，学习了！

易可赛藕 · 发表于 2018-2-1 17:34

路过，学习！！

		自动登录	找回密码
密码			免费注册

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

评分

评分

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

评分

评分

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