智能合并拆分单元格--智能批量合并相同行,拆分后填充原合并行 (VBA)

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

智能合并拆分单元格--智能批量合并相同行,拆分后填充原合并行 (VBA)_第1张图片



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


  1. Option Explicit

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

你可能感兴趣的:(VB/VBA)