智能合并拆分单元格--智能批量合并相同行，拆分后填充原合并行 （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