VBA将一行数据分为多行

1、需求：

有个表格，有许多单元格的数据，制作者为了方便，很多数据是写在一行的，类似下面这种：

做这个工作的人，一看就能知道，其实第1、2行数据都是包含了4条数据，第3、4行包含了2条数据，制作者为了方便把他们放在了一起。

这样做表格，虽然能够看懂，可是一旦我们需要使用VLookup等函数查找某一个数据的时候，就非常的不方便了，我们需要转换为下面这种：

2、举例：

本人工作中经常收到这种表格，不处理好的话，就需要手动去查找，而且是重复的工作，非常的麻烦！

3、代码实现

这个要用代码实现的话，逻辑上还是比较简单的，就是按照特定的字符把字符串拆开，然后插入行，复制数据。

本人使用一般是先手动选择一些需要处理的单元格，再运行程序。因为一般收到的表格数据是比较乱的，不敢完全按照是否包含某个字符来进行拆分！

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
        MsgBox "请选择单元格。"
        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

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