Question

I had a similar question answered Here

There is a slight twist to the scenario and hoping the macro can be changed slightly. Any help is appreciated.

Based on this Data:

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

I need this:

    <- 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 

This is the existing Macro:

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

I think this will work for you:

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