Excel宏-将逗号分隔的条目拆分为新行[重复]

Question

我目前在工作表中有这些数据

Col A   Col B   Col C
1       A       angry birds, gaming
2       B       nirvana,rock,band

我想要做的是拆分第三列中的逗号分隔条目并插入新行，如下所示：

Col A   Col B   Col C
1       A       angry birds
1       A       gaming
2       B       nirvana
2       B       rock
2       B       band

我确信这可以使用 VBA 完成，但我自己无法解决。

Answer 1

使用Scripting.Dictionary的变体

Sub ttt()
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    Dim x&, cl As Range, rng As Range, k, s
    Set rng = Range([C1], Cells(Rows.Count, "C").End(xlUp))
    x = 1 'used as a key for dictionary and as row number for output
    For Each cl In rng
        For Each s In Split(cl.Value2, ",")
            dic.Add x, Cells(cl.Row, "A").Value2 & "|" & _
                        Cells(cl.Row, "B").Value2 & "|" & LTrim(s)
            x = x + 1
    Next s, cl
    For Each k In dic
        Range(Cells(k, "A"), Cells(k, "C")).Value2 = Split(dic(k), "|")
    Next k
End Sub

来源：

结果：

Answer 2

如果您有大量数据，您会发现使用数组很有用。

Sub Macro2()
    Dim i As Long, j As Long, rws As Long
    Dim inp As Variant, outp As Variant

    With Worksheets("sheet2")
        inp = .Range(.Cells(1, "A"), .Cells(.Rows.Count, "C").End(xlUp)).Value2

        For i = LBound(inp, 1) To UBound(inp, 1)
            rws = rws + UBound(Split(inp(i, 3), ",")) + 1
        Next i

        ReDim outp(1 To rws, 1 To 3)
        rws = 0

        For i = LBound(inp, 1) To UBound(inp, 1)
            For j = 0 To UBound(Split(inp(i, 3), ","))
                rws = rws + 1
                outp(rws, 1) = inp(i, 1)
                outp(rws, 2) = inp(i, 2)
                outp(rws, 3) = Trim(Split(inp(i, 3), ",")(j))
            Next j
        Next i

        .Cells(1, "A").Resize(UBound(outp, 1), UBound(outp, 2)) = outp

    End With
End Sub

Answer 3

这不是一个完美的解决方案，但我需要花一些时间陪妻子。

但还有另一种思考方式。

此代码假设工作表名为Sheet4，需要拆分的范围为col C。

Dim lastrow As Integer
Dim i As Integer
Dim descriptions() As String

With Worksheets("Sheet4")
    lastrow = .Range("C1").End(xlDown).Row
    For i = lastrow To 2 Step -1
        If InStr(1, .Range("C" & i).Value, ",") <> 0 Then
            descriptions = Split(.Range("C" & i).Value, ",")
        End If
        For Each Item In descriptions
            .Range("C" & i).Value = Item
            .Rows(i).Copy
            .Rows(i).Insert
        Next Item
        .Rows(i).EntireRow.Delete

    Next i
End With

Answer 4

这会做你想做的。

Option Explicit

Const ANALYSIS_ROW As String = "C"
Const DATA_START_ROW As Long = 1

Sub ReplicateData()
    Dim iRow As Long
    Dim lastrow As Long
    Dim ws As Worksheet
    Dim iSplit() As String
    Dim iIndex As Long
    Dim iSize As Long

    'Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    With ThisWorkbook
        .Worksheets("Sheet1").Copy After:=.Worksheets("Sheet1")
        Set ws = ActiveSheet
    End With

    With ws
        lastrow = .Cells(.Rows.Count, ANALYSIS_ROW).End(xlUp).Row
    End With


    For iRow = lastrow To DATA_START_ROW Step -1
        iSplit = Split(ws.Cells(iRow, ANALYSIS_ROW).Value2, ",")
        iSize = UBound(iSplit) - LBound(iSplit) + 1
        If iSize = 1 Then GoTo Continue

        ws.Rows(iRow).Copy
        ws.Rows(iRow).Resize(iSize - 1).Insert
        For iIndex = LBound(iSplit) To UBound(iSplit)
            ws.Cells(iRow, ANALYSIS_ROW).Offset(iIndex).Value2 = iSplit(iIndex)
        Next iIndex
Continue:
    Next iRow

    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    'Application.ScreenUpdating = True
End Sub