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