Excel VBA - 逗號分隔單元格到行

Question

尋找VBA代碼來將包含一列逗號分隔值的動態表格轉換爲不含逗號分隔值的表格。列有標題，可以使用命名範圍來標識表和列。 「給定數據」中可能有任意數量的這些值。所以在這個例子中有4行數據，但實際上數據的範圍可以從1到300行以上。

鑑於數據（「工作表Sheet」）：

A     B  C  D 
CPN:    MPN: Price: Text: 
CPN1, CPN2, CPN3 MPN1 1.25 Example1 
CPN4, CPN6   MPN5 3.50 Example2 
CPN7    MPN4 4.20 Example3 
CPN8, CPN9   MPN2 2.34 Example4 

結果我需要的是在另一片的表，讓只說「Sheet 2中」，用行對於每個逗號在「A」與分隔值來自原始工作表的相應數據，而不從第一個工作表中刪除數據。

所需結果（「Sheet2的」）：

A  B  C  D 
CPN: MPN: Price: Text: 
CPN1 MPN1 1.25 Example1 
CPN2 MPN1 1.25 Example1 
CPN3 MPN1 1.25 Example1 
CPN4 MPN5 3.50 Example2 
CPN6 MPN5 3.50 Example2 
CPN7 MPN4 4.20 Example3 
CPN8 MPN2 2.34 Example4 
CPN9 MPN2 2.34 Example4 

我試圖修改從Here下面的代碼，但沒有能夠得到它來處理我的值類型。任何幫助將不勝感激。

Private Type data 
    col1 As Integer 
    col2 As String 
    col3 As String 
End Type 

Sub SplitAndCopy() 

    Dim x%, y%, c% 
    Dim arrData() As data 
    Dim splitCol() As String 

    ReDim arrData(1 To Cells(1, 1).End(xlDown)) 

    x = 1: y = 1: c = 1 

    Do Until Cells(x, 1) = "" 
     arrData(x).col1 = Cells(x, 1) 
     arrData(x).col2 = Cells(x, 2) 
     arrData(x).col3 = Cells(x, 3) 

     x = x + 1 
    Loop 

    [a:d].Clear 

    For x = 1 To UBound(arrData) 

     Cells(c, 2) = arrData(x).col2 
     splitCol = Split(Mid(arrData(x).col3, 2, Len(arrData(x).col3) - 2), ",") 

     ' sort splitCol 

     For y = 0 To UBound(splitCol) 
      Cells(c, 1) = arrData(x).col1 
      Cells(c, 3) = splitCol(y) 
      c = c + 1 
     Next y 

    Next x 

End Sub 

Answer 1

Public Sub textToColumns() 

Set ARange = Range("A:A") 
Set BRange = Range("B:B") 
Set CRange = Range("C:C") 
Set DRange = Range("D:D") 

Dim arr() As String 

lr = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 

Set out = Worksheets.Add 
out.Name = "out" 
outRow = 2 

For i = 2 To lr 
    arr = Split(ARange(i), ",") 
    For j = 0 To UBound(arr) 
     out.Cells(outRow, 1) = Trim(arr(j)) 
     out.Cells(outRow, 2) = BRange(i) 
     out.Cells(outRow, 3) = CRange(i) 
     out.Cells(outRow, 4) = DRange(i) 
     outRow = outRow + 1 
    Next j 
Next i 

End Sub 

我沒有做頭或與輸出紙張妥善處理，但你可以看到基本上是怎麼回事。

Answer 2

Option Explicit 

Public Sub denormalizeCSV() 
    Const FR As Byte = 2 'first row 
    Const DELIM As String = "," 
    Dim ws As Worksheet, lr As Long, lc As Long, i As Long, j As Long 
    Dim arr As Variant, thisVal As String, itms As Long 

    Set ws = Worksheets(1) 
    lr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row 
    lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column 

    Application.ScreenUpdating = False 
    With ws 
     i = FR 
     Do 
      thisVal = .Cells(i, 1).Value2 

      If InStr(thisVal, DELIM) > 0 Then 
       thisVal = Replace(thisVal, " ", vbNullString) 
       arr = Split(thisVal, DELIM) 
       itms = UBound(arr) + 1 

       .Rows(i + 1 & ":" & i + itms - 1).Insert Shift:=xlDown 
       .Range(.Cells(i, 2), .Cells(i, lc)).Copy 
       For j = i + 1 To i + itms - 1 
        .Range(.Cells(j, 2), .Cells(j, lc)).PasteSpecial xlPasteValues 
       Next 
       .Range(.Cells(i, 1), .Cells(i + itms - 1, 1)) = Application.Transpose(arr) 
       i = i + itms 
      Else 
       i = i + 1 
      End If 
     Loop Until Len(.Cells(i, 1).Value2) = 0 
    End With 
    Application.ScreenUpdating = True 
End Sub 

---

測試結果：