Excel VBA - 逗号分隔的单元格到行

Question

正在寻找 VBA 代码以将包含一列逗号分隔值的动态表转换为没有逗号分隔值的表。列有标题，命名范围可用于标识表和列。 “给定数据”中可能有任意数量的这些值行。所以在这个例子中有 4 行数据，但实际上数据的范围可以从 1 到 300 多行数据。

给定数据（“Sheet1”）：

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

我需要的结果是另一张纸上的表格，让我们说“Sheet2”，“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

适应@MacroMarc 答案，如果逗号 "," 之后或之前没有值，它将添加一个新条目，这将导致一个额外的行。所以为了避免这种情况，在写入新行之前检查分隔的值是否为空。

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)
        If Len(Trim(arr(j))) > 0 Then
            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
        End If
    Next j
Next i

End Sub