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

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

给定数据（“表1”）：

我需要的结果是在另一张表上创建一个表，比如说“Sheet2”，在“a”中为每个逗号分隔的值创建行，其中包含原始表中的相应数据，而不删除第一张表中的数据

所需结果（“表2”）：

我曾尝试从修改下面的代码，但无法使其处理我的值类型。任何帮助都将不胜感激

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

---

我没有正确处理标题或输出表，但您基本上可以看到发生了什么。

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

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

---

您知道Excel中有这样一个命令吗？这叫做文本到列。“最好的宏是没有宏”是逗号分隔值的列，总是在列A中？@iDevlop，请问文本到列如何产生所需的结果？它会将A列中的值拆分为几列，但不会为这些列生成新行。这非常有用，谢谢。你说得对，这不是抄袭书名，但这不是一个严重的问题。绝对解决了我需要的问题，谢谢！如何保留空值？

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

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

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