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

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

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

1. Option Explicit
   
2. 
   
3. Sub test()
   
4.     Dim s As Boolean, r As Range
   
5.     On Error Resume Next
   
6.     if err.number<>0 then exit sub
   
7.     s = InputBox("请输出序号选择是合并(1)或拆分(0)") '对话框选1为合并0为拆分     ' 这里不能随便去掉，即使你只是用到下面的合并或拆分其中一个功能时
   
8.     智能合并拆分 Selection, s
   
9. End Sub
   
10. Sub 智能合并拆分(r As Range, Optional mergeType As Boolean = True)
    
11. 'mergeType=1合并当前选择区域列中相同的单元格
    
12. 'mergeType=0拆分当前选择区域的合并单元格，并将原数值填充到拆分后子单元格中
    
13.     Dim rg As Range, i&, j&, ur As Range
    
14.      Application.DisplayAlerts = False
    
15.      Application.ScreenUpdating = False
    
16.     For i = 1 To r.Columns.Count '当前数据的列内循环
    
17.         j = 1
    
18.         While j <= r.Rows.Count '扫描行数据
    
19.             If mergeType Then '合并
    
20.                 Set rg = r.Cells(j, i) '待合并区第一个
    
21.                 If r.Cells(j, i) <> "" Then '跳过空单元格
    
22.                     While r.Cells(j + 1, i) = r.Cells(j, i) And j <= r.Rows.Count - 1 '新合并区向下扫描
    
23.                         j = j + 1
    
24.                         Set rg = Union(rg, r.Cells(j, i)) '构造合并区
    
25.                     Wend
    
26.                     If rg.Rows.Count > 1 Then rg.Merge
    
27.                 End If
    
28.             Else '拆分
    
29.                 If r.Cells(j, i).MergeCells = True Then '找到合并单元格，进行拆分
    
30.                     Set ur = r.Cells(j, i).MergeArea
    
31.                     ur.UnMerge
    
32.                     For Each rg In ur '填充拆分单元格
    
33.                         rg.Value = r.Cells(j, i) '将原合并单元格数据依次填充到拆分后子单元格
    
34.                     Next rg
    
35.                 End If
    
36.             End If
    
37.             j = j + 1
    
38.         Wend
    
39.      Next i
    
40.      r.Borders.LineStyle = xlContinuous '目标区线条，可根据自己需要设定
    
41.      r.Borders.Weight = xlThin
    
42.      Application.DisplayAlerts = True
    
43.      Application.ScreenUpdating = True
    
44. End Sub