Excel Macro - Comma Separated cellules à lignes Preserve/agrégat colonne

Question

J'ai eu une question similaire a répondu Here

Il y a une légère torsion au scénario et en espérant que la macro peut être légèrement modifiée. Toute aide est appréciée.

Sur la base de ces données:

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

Je en ai besoin:

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

Ceci est la macro existante:

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

Je pense que cela va fonctionner pour vous:

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