【VBA案例019】合并单元格自适应大小

1
Sub 调整合并单元格行高()
2
    Dim cel As Range
3
    Dim rng As Range
4
    Dim n, r, c
5
    Dim mergeWidth, newHeight, celWidth
6

7
    Set rng = Range("B4")
8
    For Each cel In rng
9
        If cel.MergeCells Then
10
            With cel.MergeArea
11
                mergeWidth = 0
12
                For Each c In .Columns '合并区域中的每一个单元格
13
                    mergeWidth = mergeWidth + c.ColumnWidth '新合并区域列宽=每一列列宽宽的和
14
                Next
15

16
                .MergeCells = False '取消合并单元格
17

18
                With .Cells(1)
19
                    .WrapText = True '自动换行
20
                    celWidth = .ColumnWidth '记录取消合并后列宽，目的是调整回去
21
                    .ColumnWidth = mergeWidth '调整第一个单元格宽度
22
                    .EntireRow.AutoFit '自适应大小
23
                    newHeight = .RowHeight '记录此时的行高，即合并后新的行高
24
                    .ColumnWidth = celWidth '调整回原始列宽
25
                End With
26

27
                .MergeCells = True '合并单元格
28

29
                n = .Rows.Count
30
                For Each r In .Rows
31
                    r.RowHeight = newHeight / n * 1.1 '调整每一行的行高，并*1.1微调
32
                Next
33
                .HorizontalAlignment = xlCenter '左右居中
34
                .VerticalAlignment = xlCenter ''上下居中
35
            End With
36
        End If
37
    Next
38
End Sub

1
Sub 调整合并单元格列宽()
2
    Dim cel As Range
3
    Dim rng As Range
4
    Dim n, r, c
5
    Dim mergeHeight, newWidth, celHeight
6

7
    Set rng = Range("B4")
8
    For Each cel In rng
9
        If cel.MergeCells Then
10
            With cel.MergeArea
11

12
                mergeHeight = 0
13
                For Each r In .Rows '合并区域中的每一个行
14
                    mergeHeight = mergeHeight + r.RowHeight '新合并区域行高=每一行行高的和
15
                Next
16

17
                .MergeCells = False '取消合并单元格
18

19
                With .Cells(1)
20
                    .WrapText = True '自动换行
21
                    celHeight = .RowHeight '记录取消合并后行高，目的是调整回去
22
                    .RowHeight = mergeHeight '调整第一个单元格高度
23
                    .EntireColumn.AutoFit '列宽自适应大小
24
                    newWidth = .ColumnWidth '记录此时的列宽，即合并后新的列宽
25
                    .RowHeight = celHeight '调整回原始列宽
26
                End With
27

28
                .MergeCells = True '合并单元格
29

30
                n = .Columns.Count
31
                For Each c In .Columns
32
                    c.ColumnWidth = newWidth / n * 1.1 '调整每一列的列宽，并*1.1微调
33
                Next
34
                .HorizontalAlignment = xlCenter '左右居中
35
                .VerticalAlignment = xlCenter '上下居中
36
            End With
37
        End If
38
    Next
39
End Sub