VBA - Convert multiple delimited columns into multiple row - vba

Question

I was wondering if someone can help me with the following,
In VBA in Excel, I have the following table :
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
And I would like to convert this in Excel using VBA into the following table :
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
Does anyone have an idea how to do this ?
Thank you !

Answer 1

To get my brain going I bit. This does more or less what you want (However there is room for improvement as it currently can produce duplicate rows which it then removes at the end. I've missed something but as you haven't tried anything I haven't put any more effort in figuring out where this is happening exactly).
You'll also have to change the Ranges for where your inputs and outputs come from in the ConvertToTable sub. This uses a recursive function (i.e. one that calls itself) to populate your output
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

Thank you very much, It is much appreciated. Sorry for the delay, I didn't get any e-mail notification for the response.
I played with the source code and I have the following, it works for all the column that contain short value.. :
'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
Now, I think that the code crash because I have one column that contains two long text separated by % more than a 1000 characters, I will try to change the type for arr() to see if it works but I think I am missing something in the code .