VBA 单一单元格的多行内容拆分为多行

多行拆分需求

假如一个单元格包含多行信息，比如说一些唯一的ID信息，我需要将该列的这些多行信息进行拆分，将其拆分为多行，其余列信息进行复制。例如如下图所示的示例。

可以看到，该Excel表格的A列每一行都有两行的数据，而我们的目的就是把这七行进行拆分为十四行，每一行包含单元格内单行的一条信息，其余列的文件进行复制，如下图所示。

解决方案

在这里提供一个可设定的解决方案，也是一个SUB子程序。源代码如下。

Sub SplitCopyValues()
    Dim arr As Variant
    Dim rcount As Long
    Dim ArrayLength As Integer
    
    rcount = Cells(Rows.Count, "A").End(3).Row   'Get the row num of last row
    For r = rcount To 1 Step -1             'Traverse
        arr = Split(Cells(r, "A").Value, Chr(10))       'split each item by space
        ArrayLength = UBound(arr) - LBound(arr) + 1         'calculate the array length
        For i = 1 To ArrayLength - 1
            Rows(r & ":" & r).Copy
            Rows(r + 1 & ":" & r + 1).Insert Shift:=xlDown  'insert the copied one into row+1
        Next i
        Cells(r, "A").Resize(ArrayLength, 1).Value = WorksheetFunction.Transpose(arr)  'Filling in the Created rows
        Erase arr                   'delete the arr for new one
    Next r
    Application.CutCopyMode = False

End Sub

SplitCopyValues主要就是满足了上述的多行拆分需求。我加了英文注释已经附在了代码里，非常简单明了，此外，为了理解和大家更改方便，我再用中文对代码进行详细注释。

在这里要注意的是Cells(Rows.Count, “A”).End(3).Row 中的3指的是向上搜索直到找到数据不同的消失位置。End()括号中的1、2、3、4分别代表向左、向右、向上、向下。END(x)表示从指定的单元格向左、向右、向上、向下最后一个有效RANGE。

下面是中文注释的代码：

Sub SplitCopyValues()		
    Dim arr As Variant				' arr 存储要分裂的单元格的内容
    Dim rcount As Long				' rount 就是有效的行数
    Dim ArrayLength As Integer		' arr的长度，n行长度就为n
    
    'Get the row num of last row 拿到有效的行数，具体操作为：Cells（Rows.Count," A "） 拿到A列的工作簿的最底下一个单元格（包括空）
    '.End(3) 的目的是从最底下的单元格向上寻找，找到第一个非空的单元格
    '.Row的目的是记录刚刚那个单元格的行数
    rcount = Cells(Rows.Count, "A").End(3).Row

    For r = rcount To 1 Step -1             'Traverse    对每行的行数进行循环，从最后往前进行遍历
        arr = Split(Cells(r, "A").Value, Chr(10))       'split each item by space 将该单元格以Chr（10）为分隔符进行分割
        ArrayLength = UBound(arr) - LBound(arr) + 1         'calculate the array length  计算分割后的ARR的长度
        For i = 1 To ArrayLength - 1						'对Arr内的每个元素进行遍历
            Rows(r & ":" & r).Copy                          '将该行进行复制
            Rows(r + 1 & ":" & r + 1).Insert Shift:=xlDown  'insert the copied one into row+1  '把复制的行插入到该单元格所在行的下一行
        Next i
        Cells(r, "A").Resize(ArrayLength, 1).Value = WorksheetFunction.Transpose(arr)  'Filling in the Created rows 将arr转置为列后插入到刚刚生成的哪些新的行中，也就是把A列填好
        Erase arr                   'delete the arr for new one
    Next r
    Application.CutCopyMode = False		'这是为了防止大规模复制粘贴而弹出系统默认的对话框

End Sub

希望该方法可以帮到你，有问题评论区见，我很快会回复。