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

ythtdewo

发现一个问题，想请教大家。
如果内容有上标的话，会出现算出来的高度不够的情况，应该怎么解决好呢？

下面是只选了D2单元格的时候做调整
调整前：

调整后：

可以看到最下面不能表示完全。。。

621107

ythtdewo 发表于 2014-2-7 12:13
发现一个问题，想请教大家。
如果内容有上标的话，会出现算出来的高度不够的情况，应该怎么解决好呢？

你这个上标是怎么弄出来的.. 上传上来我试试,
我原来的帖子好像没办法编辑了 我修改了下代码 修复了代码中一个复制的问题 你再试试看行不行:

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.                 rrng.Copy Destination:=wrkSheet.Cells(1, 1)
    
42.                 'wrkSheet.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
43.                 wrkSheet.Activate
    
44.                 wrkSheet.Cells(1, 1).RowHeight = 0
    
45.                 wrkSheet.Cells(1, 1).EntireRow.Activate
    
46.                 wrkSheet.Cells(1, 1).EntireRow.AutoFit
    
47.                 mySheet.Activate
    
48.                 rrng.Activate
    
49.                 If (rrng.RowHeight < wrkSheet.Cells(1, 1).RowHeight) Then
    
50.                     Dim tempHeight As Double
    
51.                     Dim tempCount As Integer
    
52.                     tempHeight = wrkSheet.Cells(1, 1).RowHeight
    
53.                     tempCount = rrng.MergeArea.Rows.Count
    
54.                     For Each addHeightRow In rrng.MergeArea.Rows
    
55.                     
    
56.                         If (addHeightRow.RowHeight < tempHeight / tempCount) Then
    
57.                             addHeightRow.RowHeight = tempHeight / tempCount
    
58.                         End If
    
59.                         tempHeight = tempHeight - addHeightRow.RowHeight
    
60.                         tempCount = tempCount - 1
    
61.                     Next
    
62.                 End If
    
63.             End If
    
64.         End If
    
65.     Next
    
66.     Application.DisplayAlerts = False '删除工作表警告提示去消
    
67.     wrkSheet.Delete
    
68.     Application.DisplayAlerts = True
    
69.     Application.ScreenUpdating = True
    
70. End Sub
    

复制代码

1990651992

楼主好人，祝你全家幸福

zhouandke

看了大家的思路, 我也写了一个函数, 方便大家阅读理解
思路:
1. 将合并区域的内容复制到一个新表的 range("A1")
2. 拆分 Range("A1"), 让所有内容都集中在 cells(1,1)
3. 让cells(1,1)的列宽等于 源range所有column的列宽
4. 让cells(1,1)自动调整行高
5. 调整合并区域的行高

下面的代码适用win7 + excel 2007, 写的是过程, 调用时, r 是要调整的合并区域, minHeight 是最小的行高
适用于宏的代码, 请自行修改一下

1. 
   
2. Sub AdjuestRangeHeight(r As Range, minHeight As Integer)
   
3.     Dim TempSheet As Worksheet
   
4.     Set TempSheet = Worksheets.Add()
   
5.     TempSheet.Visible = xlSheetHidden
   
6.    
   
7.     '带格式的复制所有内容到 TempSheet.Range("A1")
   
8.     r.Copy
   
9.     TempSheet.Range("A1").PasteSpecial xlPasteAll
   
10.     '拆分 TempSheet.Range("A1"), 让所有内容都集中在 cells(1,1)
    
11.     TempSheet.Range("A1").UnMerge
    
12.     '让cells(1,1)的列宽等于 源range所有column的列宽
    
13.     TempSheet.Cells(1, 1).ColumnWidth = 0
    
14.     For c = r.Row To r.MergeArea.Count + r.Row - 1
    
15.         TempSheet.Cells(1, 1).ColumnWidth = TempSheet.Range("A1").ColumnWidth + r.ColumnWidth
    
16.     Next
    
17.     '让cells(1,1)自动调整行高
    
18.     TempSheet.Cells(1, 1).EntireRow.AutoFit
    
19.    
    
20.     If TempSheet.Cells(1, 1).RowHeight > minHeight Then
    
21.         r.RowHeight = TempSheet.Cells(1, 1).RowHeight
    
22.     Else
    
23.         r.RowHeight = minHeight
    
24.     End If
    
25.    
    
26.     Application.DisplayAlerts = False
    
27.     TempSheet.Delete
    
28.     Application.DisplayAlerts = True
    
29. End Sub

复制代码

EXCEL江湖

好贴，多谢分享！

zhouandke

zhouandke 发表于 2014-8-21 23:10
看了大家的思路, 我也写了一个函数, 方便大家阅读理解
思路:
1. 将合并区域的内容复制到一个新表的 range ...

更新以下代码
Sub AdjuestRangeHeight(r As Range, minHeight As Integer)
    Dim TempSheet As Worksheet
    Set TempSheet = Worksheets.Add()
    TempSheet.Visible = xlSheetHidden
   
    '带格式的复制所有内容到 TempSheet.Range("A1")
    r.Copy
    TempSheet.Range("A1").PasteSpecial xlPasteAll
    '拆分 TempSheet.Range("A1"), 让所有内容都集中在 cells(1,1)
    TempSheet.Range("A1").UnMerge
    '让cells(1,1)的列宽等于 源range所有column的列宽
    TempSheet.Cells(1, 1).ColumnWidth = 0
    For c = 1 To r.MergeArea.Count
       TempSheet.Cells(1, 1).ColumnWidth = TempSheet.Cells(1, 1).ColumnWidth + r.Cells(1, c).ColumnWidth
    Next
    '让cells(1,1)自动调整行高
    TempSheet.Cells(1, 1).EntireRow.AutoFit
   
    If TempSheet.Cells(1, 1).RowHeight > minHeight Then
        r.RowHeight = TempSheet.Cells(1, 1).RowHeight
    Else
        r.RowHeight = minHeight
    End If
   
    Application.DisplayAlerts = False
    TempSheet.Delete
    Application.DisplayAlerts = True
   
End Sub

huazai688

收藏学习！！！！！！

lelouch

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

吹吹

谢谢 621107的辛苦付出及分享，赞一个。

wwelcome

根据楼主程序略改了一下，适用于所有类型单元格的行高自适应

Sub 行高自适应()
'
' 行高（包括合并单元格的行高）自适应 宏
'
    On Error Resume Next
   
    If ActiveWorkbook.Final = False Then

        Application.ScreenUpdating = False

        If Selection.MergeCells Or IsNull(Selection.MergeCells) Then    '如果选定区域里有合并单元格
               
               Dim rrng As Range, n1%
               Dim mySheet As Worksheet
               Dim selectedA As Range
               Dim wrkbookTemp As Workbook
               Dim wrkSheet As Worksheet
        
               Set mySheet = ActiveSheet
               Set selectedA = Application.Intersect(ActiveWindow.RangeSelection, mySheet.UsedRange)
               Selection.EntireRow.AutoFit
               selectedA.Activate
               selectedA.EntireRow.AutoFit
               
               Set wrkbookTemp = Workbooks.Add
               Set wrkSheet = wrkbookTemp.Sheets("Sheet1")
               
               For Each rrng In selectedA
                   If rrng.Address <> rrng.MergeArea.Address Then
                       If rrng.Address = rrng.MergeArea.Item(1).Address Then
                           Dim width1 As Double
                           Dim Height1 As Double
                           Dim tempCol
                           Dim tempRow
                           width1 = 0
                           Height1 = 0
                           For Each tempCol In rrng.MergeArea.Columns
                               width1 = width1 + tempCol.ColumnWidth
                           Next
                           For Each tempRow In rrng.MergeArea.Rows
                               Height1 = Height1 + tempRow.RowHeight
                           Next
                           
                           rrng.Copy Destination:=wrkSheet.Cells(1, 1)
                           wrkSheet.Activate
                           Cells(1, 1).Select
                           With Selection
                                .WrapText = True
                                .ColumnWidth = width1
                                .EntireRow.AutoFit
                           End With
                           Dim Height2 As Double
                           Height2 = Cells(1, 1).RowHeight
                           
                           mySheet.Activate
                           rrng.Activate
                           
                           Dim Count1 As Integer
                           Count1 = rrng.MergeArea.Rows.Count
                           
                           If (Height1 < Height2) Then
                               For Each addHeightRow In rrng.MergeArea.Rows
        
                                   If (addHeightRow.RowHeight < Height2 / Count1) Then
                                       addHeightRow.RowHeight = Height2 / Count1
                                   End If
                                   Height2 = Height2 - addHeightRow.RowHeight
                                   Count1 = Count1 - 1
                               Next
                           End If
                           
                       End If
                   End If
               Next
               
               wrkbookTemp.Close False
        
            Set rrng = Nothing
            Set mySheet = Nothing
            Set selectedA = Nothing
            Set wrkbookTemp = Nothing
            Set wrkSheet = Nothing
            Set tempCol = Nothing
            Set tempRow = Nothing
        
        Else
            
            Selection.EntireRow.AutoFit
                       
        End If
        
        Application.ScreenUpdating = ture
   
    End If

End Sub