VBA - 转换多个分隔列到多行

Question

我在想，如果有人能帮助我用下面，

在VBA在Excel中，我有如下表：

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（），看看它的工作原理，但我认为我缺少的东西代码。