VBA для разделения и переноса данных в строки [duplicate]

Это не полированное решение, но мне нужно провести некоторое время с женой.

Но еще один способ подумать об этом.

Этот код предполагает, что лист называется 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

Если у вас есть значительный объем данных, вы сможете работать с полезными массивами.

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

Это сделает то, что вы хотите.

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

Это ответ, который у меня есть для двух столбцов. Но я хочу сделать это для трех столбцов. Может ли кто-нибудь помочь мне здесь?

Вам лучше использовать альтернативные массивы, а не клеточные контуры - они намного быстрее кода, когда наборы данных имеют смысл. Даже если код длиннее:)

Этот пример ниже сбрасывается в столбцы C и D, чтобы вы могли видеть исходные данные. Изменить [c1] .Resize (lngCnt, 2) .Value2 = Application.Transpose (Y) - [a1] .Resize (lngCnt, 2) .Value2 = Application.Transpose (Y) для сброса исходных данных

[Обновлено с помощью регулярного выражения для удаления каких-либо пробелов после, т. е. «, band» становится «полосой»] Sub SliceNDice() Dim objRegex As Object Dim X Dim Y Dim lngRow As Long Dim lngCnt As Long Dim tempArr() As String Dim strArr Set objRegex = CreateObject("vbscript.regexp") objRegex.Pattern = "^\s+(.+?)$" 'Define the range to be analysed X = Range([a1], Cells(Rows.Count, "b").End(xlUp)).Value2 Redim Y(1 To 2, 1 To 1000) For lngRow = 1 To UBound(X, 1) 'Split each string by "," tempArr = Split(X(lngRow, 2), ",") For Each strArr In tempArr lngCnt = lngCnt + 1 'Add another 1000 records to resorted array every 1000 records If lngCnt Mod 1000 = 0 Then Redim Preserve Y(1 To 2, 1 To lngCnt + 1000) Y(1, lngCnt) = X(lngRow, 1) Y(2, lngCnt) = objRegex.Replace(strArr, "$1") Next Next lngRow 'Дампом переупорядоченный диапазон в столбцы C: D [c1] .Resize (lngCnt, 2) .Value2 = Application.Transpose (Y) End Sub