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 

---

测试结果：