Excel宏 - 逗號分隔細胞對行保留/聚合列

Question

我有一個類似的問題回答Here

有一個輕微的扭曲的情況下，希望宏可以稍微改變。任何幫助表示讚賞。

基於此數據：

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

我需要這樣的：

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

這是現有的宏：

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

我認爲這會爲你工作：

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