Split multiple comma separated entries from multiple columns to new rows with unique data in excel macro VBA

Question

I want to separate the values in excel with unique data. I have bunch of data like below.

1 Apple,Orange,Apricot  Fruit,Vegetable  Cat1,Cat2
2 Aubergine,Avocado     Vegetable        Cat2,Cat3,Cat4
3 Banana                Fruit            Cat5

I just want to split the above values like below split values using excel VBA. Multiple columns contains comma-separated values. Have to split values to new rows with unique data.

1 Apple      Fruit      Cat1
1 Apple      Fruit      Cat2
1 Apple      Vegetable  Cat1
1 Apple      Vegetable  Cat2
1 Orange     Fruit      Cat1
1 Orange     Fruit      Cat2
1 Orange     Vegetable  Cat1
1 Orange     Vegetable  Cat2
1 Apricot    Fruit      Cat1
1 Apricot    Fruit      Cat2
1 Apricot    Vegetable  Cat1
1 Apricot    Vegetable  Cat2
2 Aubergine  Vegetable  Cat2
.......................

Can you help me?

Answer 1

Well that sure does look an awful lot like a homework assignment for someone enrolled in an introduction to software development course.

Your first LOOP is to take the string "Apple,Orange,Apricot " which has at most 22 characters and explode it by the COMMA, then loop through its elements. Your nested second LOOP is to do likewise with the string "Fruit,Vegetable " which has at most 17 characters and explode it by the COMMA, then loop through its elements. Your nested nested third LOOP is ... you get the idea. Since Apple maps to both Fruit and Vegetable, and to both Cat1 and Cat2, the output ends up having 4 instances of Apple. This kind of extraction is also known as a Cartesian product, where 1x2x2=4.

So, the purpose of this is to teach you how to split a string on a comma character, then use the resulting array of comma-separated-strings to loop though an action.

Why isn't there a 200 point reputation bounty on this question? Hmm... hard to say (I'm joking). But on the bright side, it's just simple enough that even I can answer it, so that's something! Have a great day.

Answer 2

Public Sub SliceNDice()

    Dim objRegex As Object
    Dim X
    Dim Y
    Dim lngRow As Long
    Dim lngCnt As Long
    Dim tempArr() As String
    Dim strArr
    Set objRegex = CreateObject("vbscript.regexp")
    objRegex.Pattern = "^\s+(.+?)$"
     'Define the range to be analysed
    X = Range([a2], Cells(Rows.Count, "c").End(xlUp)).Value2
    ReDim Y(1 To 3, 1 To 1000)
    For lngRow = 1 To UBound(X, 1)
         'Split each string by ","
        tempArr = Split(X(lngRow, 2), ",")
        For Each strArr In tempArr
            lngCnt = lngCnt + 1
             'Add another 1000 records to resorted array every 1000 records
            If lngCnt Mod 1000 = 0 Then ReDim Preserve Y(1 To 3, 1 To lngCnt + 1000)
                Y(1, lngCnt) = X(lngRow, 1)
                Y(3, lngCnt) = objRegex.Replace(strArr, "$1")
        Next
    Next lngRow

    Worksheets("Test_Execution").Range("A1").Value = "Req. JIRA#"
    Worksheets("Test_Execution").Range("B1").Value = "Req. JIRA Summary"
    Worksheets("Test_Execution").Range("C1").Value = "Test JIRA#"
    Worksheets("Test_Execution").Range("D1").Value = "Test JIRA Summary"
    Worksheets("Test_Execution").Range("E1").Value = "Issue Type"
    Worksheets("Test_Execution").Range("F1").Value = "Execution Status"
    Worksheets("Test_Execution").Range("G1").Value = "Comments"


     'Dump the re-ordered range to columns C:D
    Worksheets("Test_Execution").[a2].Resize(lngCnt, 3).Value2 = Application.Transpose(Y)
End Sub