VBA 实例:Excel 自动调整合并单元格行高

1
2930

Excel 单独的单元格再设置自动换行以后,可以双击两行或两列的分隔线来调整所在单元格的高度或者宽度,一旦所在行或者所在列有合并单元格,那么上述方法就无效了,而在平时的工作中却常常遇到合并单元格需要自适应内容来调整高度,于是就找到了下面的VBA,对于调整合并单元格自适应高度挺管用的。

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

将上述宏自定义一个快捷键,然后选中所需调整单元格所在行,运行就自动适应内容高度了。

1条评论

发表回复

8 + 2 =