Sub 合并拆分()
    Dim s As Boolean, r As Range
    On Error Resume Next
    If Err.Number <> 0 Then Exit Sub
    s = InputBox("请输出序号选择是合并(1)或拆分(0)")    '对话框选1为合并0为拆分
    智能合并拆分 Selection, s
End Sub

Sub 智能合并拆分(r As Range, Optional mergeType As Boolean = True)
    'mergeType=0合并当前选择区域列中相同的单元格
    'mergeType=1拆分当前选择区域的合并单元格，并将原数值填充到拆分后子单元格中
    Dim rg As Range, i&, j&, ur As Range
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    For i = 1 To r.Columns.Count    '当前数据的列内循环
        j = 1
        While j <= r.Rows.Count    '扫描行数据
            If mergeType Then    '合并
                Set rg = r.Cells(j, i)    '待合并区第一个
                If r.Cells(j, i) <> "" Then    '跳过空单元格
                    While r.Cells(j + 1, i) = r.Cells(j, i) And j <= r.Rows.Count - 1    '新合并区向下扫描
                        j = j + 1
                        Set rg = Union(rg, r.Cells(j, i))    '构造合并区
                    Wend
                    If rg.Rows.Count > 1 Then rg.Merge
                End If
            Else    '拆分
                If r.Cells(j, i).MergeCells = True Then    '找到合并单元格，进行拆分
                    Set ur = r.Cells(j, i).MergeArea
                    ur.UnMerge
                    For Each rg In ur    '填充拆分单元格
                        rg.Value = r.Cells(j, i)    '将原合并单元格数据依次填充到拆分后子单元格
                    Next rg
                End If
            End If
            j = j + 1
        Wend
    Next i
    r.Borders.LineStyle = xlContinuous    '目标区线条，可根据自己需要设定
    r.Borders.Weight = xlThin
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub