texto - Macro de Excel-Células separadas por comas a columnas Preservar/Columna de agregado

separar texto en excel con funciones

Question

Me respondieron una pregunta similar aquí

Hay un ligero giro en el escenario y esperamos que la macro se pueda cambiar ligeramente. Cualquier ayuda es apreciada.

En base a esta información:

    <- A (Category) ->   <- B (Items) -> 
1   Cat1                 a,b, c
2   Cat2                 d
3   Cat3                 e
4   Cat4                 f, g

Necesito este:

    <- A (Category) ->   <- B (Items) -> 
1   Cat1                 a
2   Cat1                 b
3   Cat1                 c
4   Cat2                 d
5   Cat3                 e
6   Cat4                 f
7   Cat4                 g

Esta es la Macro existente:

Option Explicit
Sub Macro1()
    Dim fromCol As String
    Dim toCol As String
    Dim fromRow As String
    Dim toRow As String
    Dim inVal As String
    Dim outVal As String
    Dim commaPos As Integer

    '' Copy from column A to column B.''
    fromCol = "A"
    toCol = "B"
    fromRow = "1"
    toRow = "1"

    '' Go until no more entries in column A.''
    inVal = Range(fromCol + fromRow).Value
    While inVal <> ""

        '' Go until all sub-entries used up.''
        While inVal <> ""
            Range(fromCol + fromRow).Select

            '' Extract each subentry.''
            commaPos = InStr(1, inVal, ",")
            While commaPos <> 0

                '' and write to output column.''
                outVal = Left(inVal, commaPos - 1)
                Range(toCol + toRow).Select
                Range(toCol + toRow).Value = outVal
                toRow = Mid(Str(Val(toRow) + 1), 2)

                '' Remove that sub-entry.''
                inVal = Mid(inVal, commaPos + 1)
                While Left(inVal, 1) = " "
                    inVal = Mid(inVal, 2)
                Wend
                commaPos = InStr(1, inVal, ",")
            Wend

            '' Get last sub-entry (or full entry if no commas).''
            Range(toCol + toRow).Select
            Range(toCol + toRow).Value = inVal
            toRow = Mid(Str(Val(toRow) + 1), 2)
            inVal = ""
        Wend

        '' Advance to next source row.''
        fromRow = Mid(Str(Val(fromRow) + 1), 2)
        Range(fromCol + fromRow).Select
        inVal = Range(fromCol + fromRow).Value
    Wend
End Sub

Answer 1

Creo que esto funcionará para ti:

Sub ExpandData()
    Const FirstRow = 2
    Dim LastRow As Long
    LastRow = Range("A" & CStr(Rows.Count)).End(xlUp).Row

    '' Get the values from the worksheet
    Dim SourceRange As Range
    Set SourceRange = Range("A" & CStr(FirstRow) & ":B" & CStr(LastRow))

    '' Get sourcerange values into an array
    Dim Vals() As Variant
    Vals = SourceRange.Value

    '' Loop through the rows in the array and split each comma-delimited list of items and put each on its own row
    Dim ArrIdx As Long
    Dim RowCount As Long
    For ArrIdx = LBound(Vals, 1) To UBound(Vals, 1)

        Dim CurrCat As String
        CurrCat = Vals(ArrIdx, 1)

        Dim CurrList As String
        CurrList = Replace(Vals(ArrIdx, 2), " ", "")

        Dim ListItems() As String
        ListItems = Split(CurrList, ",")

        Dim ListIdx As Integer
        For ListIdx = LBound(ListItems) To UBound(ListItems)

            Range("A" & CStr(FirstRow + RowCount)).Value = CurrCat
            Range("B" & CStr(FirstRow + RowCount)).Value = ListItems(ListIdx)
            RowCount = RowCount + 1

        Next ListIdx

    Next ArrIdx

End Sub