Excel VBA之合并单元格操作

时　间:2012-08-08 09:01:26
作　者:叶海峰   ID：31  城市：广州
摘　要:Excel VBA之合并单元格操作。
正　文:

Sub mergecells()     '自动合并单元格
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim cell   As Range
    Dim i, b   As Integer
    i = Selection.Rows.count - 1
    For b = 1 To i
        With ActiveCell
            .Select
            If .Offset(1, 0) = .Value Then
                Range(ActiveCell, .Offset(1, 0)).Select
                Selection.mergecells = True
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            Else
                .Offset(1, 0).Select
            End If
        End With
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Sub mergecells_insertvalue()    '自动拆分合并单元格+填充值
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error GoTo tuichu
    Dim cell   As Range
    Dim i, a   As Integer  '填充上一行值
    Dim j, k   As Byte
    Dim rng    As String
    i = Selection.Rows.count
    k = Selection.Columns.count
    For Each cell In Selection
        If cell.mergecells = True Then
            cell.mergecells = False
        End If
    Next
    rng = ActiveCell.Address
    For j = 0 To k - 1
        For a = 1 To i
            With ActiveCell
                If .Value = "" Then
                    .Offset(-1, 0).Copy
                    .PasteSpecial xlPasteAll
                End If
                .Offset(1, 0).Select
            End With
        Next
        Range(rng).Offset(0, j + 1).Activate
    Next

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
tuichu:
End Sub

Sub 拆分合并单元格_填充平均值()
    Dim ma     As Range
    Dim a      As Variant
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each rng In Selection
        a = rng.Value
        If rng.mergecells = True Then
            Set ma = rng.MergeArea
            rng.mergecells = False
            Range(ma.Address) = a / ma.Cells.count
        End If
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

演   示: