按公式将单元格拆分为不同的行

Question

我有一张这样的表

Column1 Column2
a   m
a   n m
b   j k l u
c   o
d   f g
d   k l n

我想将具有不同项目的单元格拆分为不同的行，如此

Column1 Column2
a   m
a   m
a   n
b   j
b   k
b   l
b   u
c   o

在你的想法中我该怎么做？

Answer 1

假设您的数据位于Sheet1，结果将显示在Sheet2中。请尝试以下代码：

Sub Demo()
    Dim lastRow As Long, lastcolumn As Long, rowCnt As Long
    Dim dataWS As Worksheet, outputWS As Worksheet
    Dim dict1 As Object, dict2 As Object
    Dim arr() As String, temp As String

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set dict1 = CreateObject("Scripting.dictionary")
    Set dict2 = CreateObject("Scripting.dictionary")

    'set your sheets here
    Set dataWS = ThisWorkbook.Sheets("Sheet1")
    Set outputWS = ThisWorkbook.Sheets("Sheet2")

    'get last row with data in Sheet1
    lastRow = dataWS.Cells(Rows.Count, "A").End(xlUp).Row

    rowCnt = 1
    For i = 1 To lastRow
        temp = dataWS.Cells(i, 2).Value
        'get each value in Column B separated by space " "
        arr = Split(temp, " ")
        For j = LBound(arr) To UBound(arr)
            'add values in dictionary
            dict1.Add Item:=dataWS.Cells(i, 1).Value, Key:=rowCnt
            dict2.Add Item:=arr(j), Key:=rowCnt
            rowCnt = rowCnt + 1
        Next j
    Next i

    'display result in Sheet2
    outputWS.Range("A1").Resize(dict1.Count) = Application.Transpose(dict1.items)
    outputWS.Range("B1").Resize(dict2.Count) = Application.Transpose(dict2.items)

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

见图片参考：