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（），看看它的工作原理，但我認爲我缺少的東西代碼。