Unpivot 'Comma' Separated

Sample Data

Country;Fruits
France;Apple,Oranges
Germany;Oranges,Bananas
UK;Grapes,Lemons
Sweden;Mandarines,Strawberries,Bananas, Apples

Create (OP)

=IF(A1="","",A1&";"&B1)

1. Copy (CTRL+C) the range and paste (CTRL+V) it into NotePad.
2. Select All and Copy (CTRL+A, CTRL+C)
3. Paste here (CTRL+V).
4. Select the whole text and either click the code sample icon ({}) or use CTRL+K.

Use (User)

1. Select the text and copy (CTRL+C),
2. Right-click the first cell (A1) and Paste (Match Destination Formatting),
3. Data > TextToColumns,
4. Next,
5. Delimiter: check Semicolon
6. Finish

Program

Usage/Features

• Caution: If you use the same worksheets and the same first cell addresses, you will be overwriting.
  Note that there is no Undo.
• Adjust the values of the four constants.
• Open the Immediate window (CTRL+G) to see the range addresses at the various stages.
• Application.Trim will cover any redundant spaces like the one in Swedish apples.

The Code

Option Explicit

Sub unpivotCommaSeparated()
    
    Const sName As String = "Sheet1"
    Const sFirst As String = "A1"
    
    Const dName As String = "Sheet1"
    Const dFirst As String = "D1"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sData As Variant
    Dim rg As Range
    Dim isDataInArray As Boolean
    
    With wb.Worksheets(sName).Range(sFirst)
        Debug.Print "Source First Cell:                " & .Address(0, 0)
        Set rg = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If Not rg Is Nothing Then
            Debug.Print "Source Last Cell in First Column: " & rg.Address(0, 0)
            Set rg = .Resize(rg.Row - .Row + 1, 2)
            Debug.Print "Source Range:                     " & rg.Address(0, 0)
            sData = rg.Value
            isDataInArray = True
        End If
    
    End With
    
    If isDataInArray Then
        
        Dim srCount As Long: srCount = UBound(sData, 1)
        Dim cCount As Long: cCount = UBound(sData, 2)
        ReDim Preserve sData(1 To srCount, 1 To cCount + 1)
        
        Dim drCount As Long: drCount = 1
        Dim i As Long
        
        For i = 2 To srCount
            sData(i, 2) = Split(sData(i, 2), ",")
            sData(i, 3) = UBound(sData(i, 2))
            drCount = drCount + sData(i, 3) + 1
        Next i
        
        Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
        Dim j As Long
        
        For j = 1 To cCount
            dData(1, j) = sData(1, j)
        Next j
            
        Dim k As Long: k = 1
        
        For i = 2 To srCount
            For j = 0 To sData(i, 3)
                k = k + 1
                dData(k, 1) = sData(i, 1)
                dData(k, 2) = Application.Trim(sData(i, 2)(j))
            Next j
        Next i
    
        With wb.Worksheets(dName).Range(dFirst).Resize(, cCount)
            Debug.Print "Destination First Row Range:      " & .Address(0, 0)
            Set rg = .Resize(k)
            Debug.Print "Destination Range:                " & rg.Address(0, 0)
            rg.Value = dData
            Set rg = .Resize(.Worksheet.Rows.Count - .Row - k + 1).Offset(k)
            Debug.Print "Clear Range:                      " & rg.Address(0, 0)
            rg.ClearContents
        End With
    
    End If
    
End Sub

SOLVED!! (2 STEPS)

(A) QUICK-START GUIDE

Google-sheets (screenshots below) here (perma-link, self-same content / functions included below in any case!). Key for labels 1 & 2:

• Label 1 (e.g. 'country' in original Q - font colour = blue in screenshots below)
• Label 2 (e.g. 'fruit' in original Q - font colour = green in screenshots below)

(B) STEPS 1-2

(preface: may as well be entitled 'two-function' soln...)

STEP 1: FILTERXML as dynamic array applied to Label 1 in first instance (ref: 8 ways to split text by delimiter - J./ MacDougall Note: this is one of 2 methods that shall be considered for Step 1.

FilterXML screenshot

FilterXML function in the context of above screenshot:

=FILTERXML("<t><s>"&SUBSTITUTE(ARRAYTOTEXT(D6:D10),",","</s><s>")&"</s></t>","//s")

STEP 2. INDEX-ARRAY (map Label 1 values to corresponding Label 2 values after applying FILTERXML step)

• Utilises new Excel 'array' feature which only requires populating first cell - array produced this way will then 'fill down' into adjacent cells as req.
• Note: 'old' array functionality can still be used / adopted by typing function into first cell, then pressing 'ctrl'+'alt'+'enter'.
• Doing so may restrict ability to use hash references for arrays as I've done here
• Index can often be seen with match component / function. In this case, match lookup value utilises '*' wildcards (this feature makes match functions exceptionally versatile)

Index-Array screenshot

Index-Array function in the context of above screenshot:

=INDEX($C$6:$C$10,MATCH("*"&D16#&"*",$D$6:$D$10,0))[5]

(C) OTHER VIABLE TECHNIQUES

Viable in context of other priorities, budget, etc.

i) VB Code

• Effectively based upon self-same formulation already provided - hence the 'sub' name'... :)

Modify/adjust as you deem fit/as req.

Sub Boring_Split_Code():
    ActiveCell.Formula2R1C1 = _
        "=FILTERXML(""<t><s>""&SUBSTITUTE(ARRAYTOTEXT(R[-12]C:R[-8]C),"","",""</s><s>"")&""</s></t>"",""//s"")"
    Range("C22").Select
    'Application.CutCopyMode = False
    ActiveCell.Formula2R1C1 = _
        "=INDEX(R10C3:R14C3,MATCH(""*""&RC[1]#&""*"",R10C4:R14C4,0))"
End Sub

ii) VB 'mechanical-unpivot' method

• Ref: O. Cronquist
• Imagine this is what you were after when Q first posted
• However, only features after my 'boring' sub above given I strongly recommend using a more elegant solution (e.g. FilterXML / Index-Array)
• Devil's advocate: this approach may still prove preferable depending on use-case / objective
• Caveats abound - may require 'tweaking' or post-execution manipulation to address 'blank' cells
• Recommend using 'unique() Excel formula to address if/as req.- see here for further detail re: 'unique' function

Sub Unpivot()
'
' Unpivot Macro
' Creates pivot flat file source format from table with rows and columns

Dim rng As Range
Dim Ws As Worksheet

On Error Resume Next
Set rng = Application.InputBox(Prompt:="Select a range to normalize data" _
, Title:="Select a range", Default:=ActiveCell.address, Type:=8)
On Error GoTo 0

If rng Is Nothing Then
Else
    Application.ScreenUpdating = False
    Set Ws = Sheets.Add
    i = 0
    For r = 1 To rng.Rows.Count - 1
        For c = 1 To rng.Columns.Count - 1
            Ws.Range("A1").Offset(i, 0) = rng.Offset(0, c).Value
            Ws.Range("A1").Offset(i, 1) = rng.Offset(r, 0).Value
            Ws.Range("A1").Offset(i, 2) = rng.Offset(r, c).Value
            i = i + 1
        Next c
    Next r
    Ws.Range("A:C").EntireColumn.AutoFit
    Application.ScreenUpdating = True
End If
End Sub

iii) Popular Mid / Match variants...

• Less elegant alternate to 'funky' FilterXML method
• (index-array method/equivalent still required)

Mid-Match (Step 1, Method 2) screenshot

Mid-Match functions

In the context of recent above screenshot:

= SUBSTITUTE(ARRAYTOTEXT(D6:D10)," ","")

Primes/prepares raw data for mid/substitute/search applications...

= MID(E23,1,SEARCH(",",E23)-1)

Initiates recursive substitute method, defined as follows (data rows 2+):

 = MID( SUBSTITUTE(E$23, CONCAT(E$24:E24 & "," ), ""  ), 1, IFERROR( SEARCH( ",", SUBSTITUTE(E$23, CONCAT( E$24:E24 & "," ),"" ) ) - 1, LEN( $E$23 ) ) )