合并单元格也能"最适合行高"

621107

昨天老婆处理EXCEL的时候遇到的，EXCEL自带的最适合行高不能作用于合并单元格。
google了很久都找不到方法，听说excel宏很强大我就自己试试编写一下这个功能。。
花了几个小时终于搞定，现在分享给大家，顺便大家帮忙找找BUG~~

主要思路：建立1个临时的工作表T，复制 合并单元格的 内容、字体大小、宽度 到临时表T
然后让EXCEL去计算最适合行高 goodHeight，我再把这个行高 与 合并单元格包含的所有行的行高去比较
计算平均每行需要多少高度 （goodHeight / rows.count） 如果这个高度比这个row的高度低 那么就不要设置(会破坏这一行已经设置好了的高度)
最后删除临时表T.

1. Sub My_MergeCell_AutoHeight()
   
2.     Dim rh As Single, mw As Single
   
3.     Dim rng As Range, rrng As Range, n1%, n2%
   
4.     Dim aw As Single, rh1 As Single
   
5.     Dim m$, n$, k
   
6.     Dim ir1, ir2, ic1, ic2
   
7.     Dim mySheet As Worksheet
   
8.     Dim selectedA As Range
   
9.     Dim wrkSheet As Worksheet
   
10.    
    
11.     Application.ScreenUpdating = False
    
12.     Set mySheet = ActiveSheet
    
13.     On Error Resume Next
    
14.     Err.Number = 0
    
15.     Set selectedA = Application.Intersect(ActiveWindow.RangeSelection, mySheet.UsedRange)
    
16.     selectedA.Activate
    
17.     If Err.Number <> 0 Then
    
18.     g = MsgBox("请先选择需要'最合适行高'的行!", vbInformation)
    
19.     Return
    
20.     End If
    
21.     selectedA.EntireRow.AutoFit
    
22.     Set wrkSheet = ActiveWorkbook.Worksheets.Add
    
23.     For Each rrng In selectedA
    
24.         If rrng.Address <> rrng.MergeArea.Address Then
    
25.             If rrng.Address = rrng.MergeArea.Item(1).Address Then
    
26.                
    
27.                 'If (Application.Intersect(selectedA, rrng).Address <> rrng.Address) Then
    
28.                 '    GoTo gotoNext
    
29.                 'End If
    
30.                
    
31.                 Dim tempCell As Range
    
32.                 Dim width As Double
    
33.                 Dim tempcol
    
34.                 width = 0
    
35.                 For Each tempcol In rrng.MergeArea.Columns
    
36.                     width = width + tempcol.ColumnWidth
    
37.                 Next
    
38.                 wrkSheet.Columns(1).WrapText = True
    
39.                 wrkSheet.Columns(1).ColumnWidth = width
    
40.                 wrkSheet.Columns(1).Font.Size = rrng.Font.Size
    
41.                 wrkSheet.Cells(1, 1).Value = rrng.Value
    
42.                 wrkSheet.Activate
    
43.                 wrkSheet.Cells(1, 1).RowHeight = 0
    
44.                 wrkSheet.Cells(1, 1).EntireRow.Activate
    
45.                 wrkSheet.Cells(1, 1).EntireRow.AutoFit
    
46.                 mySheet.Activate
    
47.                 rrng.Activate
    
48.                 If (rrng.RowHeight < wrkSheet.Cells(1, 1).RowHeight) Then
    
49.                     Dim tempHeight As Double
    
50.                     Dim tempCount As Integer
    
51.                     tempHeight = wrkSheet.Cells(1, 1).RowHeight
    
52.                     tempCount = rrng.MergeArea.Rows.Count
    
53.                     For Each addHeightRow In rrng.MergeArea.Rows
    
54.                     
    
55.                         If (addHeightRow.RowHeight < tempHeight / tempCount) Then
    
56.                             addHeightRow.RowHeight = tempHeight / tempCount
    
57.                         End If
    
58.                         tempHeight = tempHeight - addHeightRow.RowHeight
    
59.                         tempCount = tempCount - 1
    
60.                     Next
    
61.                 End If
    
62.             End If
    
63.         End If
    
64.     Next
    
65.     Application.DisplayAlerts = False '删除工作表警告提示去消
    
66.     wrkSheet.Delete
    
67.     Application.DisplayAlerts = True
    
68.     Application.ScreenUpdating = True
    
69. End Sub

复制代码

大家讨论讨论还有什么可以改进的没, 下面的文件是宏文件，需要使用EXCEL加载宏功能添加。加载后有一个新的工具栏，点红色灯泡图标就能使用这个功能了。

[ 本帖最后由 621107 于 2011-3-28 17:17 编辑 ]

补充内容 (2014-6-12 19:28):
新版本的excel 可能已经用不了这个方式去加载宏了  大家 在excel中 自己添加宏 把这代码贴过去 新增宏 去使用吧

补充内容 (2014-6-12 19:29):
代码有一次小更新在 32楼

621107

忘记加个测试用的excel文件了 补上..

[ 本帖最后由 621107 于 2011-3-28 16:53 编辑 ]

飞云楼主

支持原创和分享。

morewit

刚才使用了一下，很好用！谢谢！

lgl420

这个工具可以调整合并单元格的行高，但是需要填写后再设置方可，能不能做到设置一个模板它会根据你填的内容自动调整，而不需要我们自己去设置。

621107

lgl420 发表于 2011-7-27 09:15
这个工具可以调整合并单元格的行高，但是需要填写后再设置方可，能不能做到设置一个模板它会根据你填的内容 ...

这个功能很好.. 不过估计要使用更复杂的设计了.
因为要考虑到很多不同的情况 比如某些合并格需要自动行高某些又不需要...
要做的像EXCEL内置的自动行高功能那样方便就好了.希望有更厉害的高手帮忙实现哈..

1911330126

不错，可以用，感谢分享

盐丁

不错，关注留个脚印，打个记号。

cyp831118yzp

高手辛苦了就是复杂了点。

wam1128

在klx博客看到一种方法：

http://blog.chinaunix.net/uid-574845-id-2734221.html


用宏设置 excel2010合并单元格能自动换行



Sub AutoFitMergedCellRowHeight()
'
' AutoFitMergedCellRowHeight 宏
'
Dim oAdd As Object
Set oAdd = Application.COMAddIns("ESClient10.Connect").Object
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
If ActiveCell.MergeCells Then
With ActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
End If

Set oAdd = Nothing

End Sub

请楼主指导，excel 上怎么自动加载上面的代码呢。比如，我一打开excel就自动加载上面的宏内容。