Excel里有个分列的功能，能根据单元格中指定的符号，把单元格拆分为多个单元格，并按列存放。
有时候会碰上需要按指定的符号，将某些单元格拆分为多行，并且同一行的其他单元格完全复制的情况：
首先在customUI.xml中增加代码：
代码语言：javascript复制 <button id="rbbtnSplitRows" label="分行 " size="large" onAction="rbbtnSplitRows" imageMso="CreateDiagram" />回调函数：
代码语言：javascript复制Sub rbbtnSplitRows(control As IRibbonControl)
Call MRange.SplitRows
End Sub函数实现：
代码语言：javascript复制Private Type SplitDataStruct
rng As Range '要处理的单元格
StrSplit As String '要根据什么字符来拆分
FlagPre As Boolean '是否保持前缀
End Type
Sub SplitRows()
Dim d As SplitDataStruct
Dim rngSelect As Range
If VBA.TypeName(Selection) <> "Range" Then
Exit Sub
End If
Set rngSelect = Selection
If rngSelect.Columns.Count > 1 Then
MsgBox "请选择单列。"
Exit Sub
End If
Dim kCells As Long, i As Long
kCells = rngSelect.Cells.Count
'这里主要是为了方便自动输入一些经常碰到的要拆分的字符
Dim strDefault As String
strDefault = "/"
Dim strRng As String
strRng = rngSelect.Cells(1).Value
If VBA.InStr(strRng, " ") Then
strDefault = " "
ElseIf VBA.InStr(strRng, "、") Then
strDefault = "、"
End If
d.StrSplit = Application.InputBox("请输入拆分字符。", "输入", strDefault, Type:=2)
If VBA.Len(d.StrSplit) Then
If d.StrSplit <> "False" Then
If VBA.MsgBox("插入时是否保持前缀？" & vbNewLine & vbNewLine & "如ABCDEFG1/2，拆分后是ABCDEFG1和ABCDEFG2，ABCDEFG为前缀", vbYesNo) = vbYes Then
d.FlagPre = True
Else
d.FlagPre = False
End If
'因为要插入行,所以从最底下的单元格往上处理
For i = kCells To 1 Step -1
Set d.rng = rngSelect.Cells(i)
SplitRngToRows d
Next
End If
End If
End Sub
Private Function SplitRngToRows(d As SplitDataStruct) As Long
Dim strValue As String, strPre As String
Dim tmp, k As Long, i As Long, flag As Boolean
strValue = VBA.CStr(d.rng.Value)
If VBA.InStr(strValue, d.StrSplit) Then
tmp = VBA.Split(strValue, d.StrSplit)
k = UBound(tmp) '需要插入的行，本身有一行,tmp下标是0,所以要插入的是k行
d.rng.Offset(1, 0).Resize(k, 1).EntireRow.Insert xlShiftDown
'其他列的数据都复制保持一致
d.rng.EntireRow.Copy d.rng.Offset(1, 0).Resize(k, 1).EntireRow
d.rng.Value = tmp(0)
If d.FlagPre Then
strPre = VBA.Left$(tmp(0), VBA.Len(tmp(0)) - VBA.Len(tmp(1)))
End If
For i = 1 To k
If d.FlagPre Then
d.rng.Offset(i, 0).Value = strPre & VBA.CStr(tmp(i))
Else
d.rng.Offset(i, 0).Value = tmp(i)
End If
Next
End If
End Function
