VBA - 将多个分隔列转换为多行

Question

我想知道是否有人可以帮助我解决以下问题，

在 Excel 的 VBA 中，我有下表：

Column 1|Column2|Column3|Column4|Column5|Column6
---------|---------|---------|---------|---------|---------
1.2.3.4|Apple%Car|Canada%USA|Tomatoes|Hotel|Montreal%Paris%New-York
1.3.4.6|Cat%Uniform%Dog|France|Ananas|Motel|Amsterdam%San-Diego

我想在 Excel 中使用 VBA 将其转换为下表：

 Column 1|Column 2|Column 3|Column 4|Column 5|Column 6
 :---------:|:---------:|:---------:|:---------:|:---------:|:---------:
 1.2.3.4|Apple|Canada|Tomatoes|Hotel|Montreal
 1.2.3.4|Apple|Canada|Tomatoes|Hotel|Paris
 1.2.3.4|Apple|Canada|Tomatoes|Hotel|New-York
 1.2.3.4|Apple|USA|Tomatoes|Hotel|Montreal
 1.2.3.4|Apple|USA|Tomatoes|Hotel|Paris
 1.2.3.4|Apple|USA|Tomatoes|Hotel|New-York
 1.2.3.4|Car|Canada|Tomatoes|Hotel|Montreal
 1.2.3.4|Car|Canada|Tomatoes|Hotel|Paris
 1.2.3.4|Car|Canada|Tomatoes|Hotel|New-York
 1.2.3.4|Car|USA|Tomatoes|Hotel|Montreal
 1.2.3.4|Car|USA|Tomatoes|Hotel|Paris
 1.2.3.4|Car|USA|Tomatoes|Hotel|New-York
 1.3.4.6|Cat|France|Ananas|Motel|Amsterdam
 1.3.4.6|Cat|France|Ananas|Motel|San-Diego
 1.3.4.6|Uniform|France|Ananas|Motel|Amsterdam
 1.3.4.6|Uniform|France|Ananas|Motel|San-Diego
 1.3.4.6|Dog|France|Ananas|Motel|Amsterdam
 1.3.4.6|Dog|France|Ananas|Motel|San-Diego

有人知道怎么做吗？

谢谢！

Answer 1

为了让我的大脑运转，我咬了一口。这或多或少可以满足您的需求（但是还有改进的余地，因为它目前可以产生重复的行，然后在最后将其删除。我错过了一些东西，但是由于您没有尝试任何东西，所以我没有再放努力找出发生这种情况的确切位置）。

您还必须在 ConvertToTable 子中更改输入和输出的来源范围。这使用递归函数（即调用自身的函数）来填充您的输出

Option Explicit
Public Sub ConvertToTable()
    Dim data As Variant, tmp() As Variant
    Dim arr() As Variant
    Dim i As Long
    Dim c As Range

    With Sheet2
        data = Range(.Cells(1, 1), .Cells(2, 6)).Value2
    End With

    For i = LBound(data, 1) To UBound(data, 1)
        tmp = Application.Index(data, i, 0)
        arr = PopulateResults(tmp, "%", arr)
    Next i
    With Sheet4
        With .Range(.Cells(1, 1), .Cells(UBound(arr, 2), UBound(arr, 1)))
            .Value2 = Application.Transpose(arr)
            .RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6), Header:=xlNo
        End With
    End With
End Sub

---

Public Function PopulateResults(tmp As Variant, delimiter As String, Results() As Variant) As Variant()
    Dim i As Long, j As Long
    Dim DelCount As Long, MaxDel As Long
    Dim tmp2 As Variant

    On Error Resume Next
    i = UBound(Results, 2) + 1
    If i = 0 Then i = 1
    On Error GoTo 0

    ReDim Preserve Results(1 To UBound(tmp), 1 To i)
    For j = 1 To UBound(tmp)
        Results(j, i) = tmp(j)
        If InStr(1, tmp(j), delimiter, vbTextCompare) Then
            DelCount = 0
            Results(j, i) = Split(tmp(j), delimiter)(DelCount)
            Do
                DelCount = DelCount + 1
                tmp2 = tmp
                tmp2(j) = Split(tmp(j), delimiter)(DelCount)
                Results = PopulateResults(tmp2, delimiter, Results)
            Loop Until DelCount = Len(tmp(j)) - Len(Replace(tmp(j), delimiter, vbNullString))
        End If
    Next j
    PopulateResults = Results
End Function

Answer 2

非常感谢，非常感谢。抱歉耽搁了，我没有收到任何回复的电子邮件通知。

我玩过源代码，我有以下内容，它适用于所有包含短值的列..：

'Transform the data
Dim data As Variant, tmp() As Variant
Dim arr() As String
Dim i As Long
Dim c As Range

    With Aggregation_Source
        data = Range(Cells(1, 1), Cells(2, 8)).Value2
    End With

    For i = LBound(data, 1) To UBound(data, 1)
        tmp = Application.Index(data, i, 0)
        arr = PopulateResults(tmp, "%", arr)
    Next i

With Aggregation_Source
        With Range(Cells(1, 1), Cells(UBound(arr, 2), UBound(arr, 1)))
            .Value2 = Application.Transpose(arr)
            .RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlNo
        End With
    End With
End Sub

Public Function PopulateResults(tmp As Variant, delimiter As String, Results() As String) As String()
    Dim i As Long, j As Long
    Dim DelCount As Long, MaxDel As Long
    Dim tmp2 As Variant

    On Error Resume Next
    i = UBound(Results, 2) + 1
    If i = 0 Then i = 1
    On Error GoTo 0

    ReDim Preserve Results(1 To UBound(tmp), 1 To i)
    For j = 1 To UBound(tmp)
        Results(j, i) = tmp(j)
        If InStr(1, tmp(j), delimiter, vbTextCompare) Then
            DelCount = 0
            Results(j, i) = Split(tmp(j), delimiter)(DelCount)
            Do
                DelCount = DelCount + 1
                tmp2 = tmp
                tmp2(j) = Split(tmp(j), delimiter)(DelCount)
                Results = PopulateResults(tmp2, delimiter, Results)
            Loop Until DelCount = Len(tmp(j)) - Len(Replace(tmp(j), delimiter, vbNullString))
        End If
    Next j
    PopulateResults = Results
End Function

现在，我认为代码崩溃是因为我有一列包含两个长文本，由 % 分隔超过 1000 个字符，我将尝试更改 arr() 的类型以查看它是否有效，但我想我我在代码中遗漏了一些东西。