Excel-VBA智能合并拆分单元格–智能批量合并相同行，拆分后填充原合并行

keywords:合并，单元格，拆分，VBA，excel 看到有人问合并拆分单元格，系统的拆分合并比较死板 做了这个工具 可以智能拆分或者合并用户选定区域（可多个连续列批量操作，暂不支持不连续选区） 操作效果如动画所示
 

代码如下 应该有人能用得到

Option Explicit
 
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

    1VBA-智能合并及拆分单元格.rar