Copy rows from range and split up cell values

Question

I am trying to find a solution for the following problem. I have a range in Excel based on a data export of the type below in simplified form:

Task	Date	Name
task1	date1	john
task2	date2	matt; jack; john
task3	date3	martin; jack
task4	date4	matt

For better analysis I want to create a macro using VBA that makes a new range which only contains single values in the cells. Therefore cells in the column "Name" have to be split up in more than one rows in case there are more than one names separated by semicolons.

I want the new range to be copied in a new worksheet and look like the following:

Task	Date	Name
task1	date1	john
task2	date2	matt
task2	date2	jack
task2	date2	john
task3	date3	martin
task3	date3	jack
task4	date4	matt

Unfortunately I haven't found a proper solution yet, so I thought I might be able to find some help here. Many thanks in advance!

Split the name column by delimiter; then unpivot the name columns. You can do this in VBA or Power Query and there are examples in this forum. — Ron Rosenfeld
@RonRosenfeld I guess "unpivot" is the key word I missed in that case. Thank you! — matthoc

VBasic2008 VBasic2008 · Accepted Answer · 2021-02-23T13:41:24

Unpivot Column With Delimited Strings

Adjust the values in the constants section.

The Code

Option Explicit

Sub uvpivotSeparated()
    
    ' Source
    Const sName As String = "Sheet1"
    Const sFirst As String = "A1"
    Const sepCol As Long = 3
    ' Destination
    Const dName As String = "Sheet2"
    Const dFirst As String = "A1"
    ' Other
    Const Delimiter As String = "; "
    
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Define Source Range.
    Dim rg As Range: Set rg = wb.Worksheets(sName).Range(sFirst)
    With rg.CurrentRegion
        Set rg = rg.Resize(.Row + .Rows.Count - rg.Row, _
            .Column + .Columns.Count - rg.Column)
    End With
    
    ' Write values from Source Range to Data Array.
    Dim Data As Variant: Data = rg.Value
    Dim srCount As Long: srCount = UBound(Data, 1)
    Dim dcCount As Long: dcCount = UBound(Data, 2)
    Dim scCount As Long: scCount = dcCount + 1
    
    ' Add a column to Data Array.
    ReDim Preserve Data(1 To srCount, 1 To scCount)
    
    ' Calculate Result Array Rows Count, replace each separated value
    ' with an array, and write its upper bound to the extra column.
    Dim drCount As Long: drCount = 1 ' headers
    Dim i As Long
    For i = 2 To srCount
        Data(i, sepCol) = Split(Data(i, sepCol), Delimiter)
        Data(i, scCount) = UBound(Data(i, sepCol))
        drCount = drCount + Data(i, scCount) + 1
    Next i
    
    ' Define Result Array.
    Dim Result As Variant: ReDim Result(1 To drCount, 1 To dcCount)
    ' Write headers.
    Dim j As Long
    For j = 1 To dcCount
        Result(1, j) = Data(1, j)
    Next j
    ' Write body.
    Dim k As Long: k = 1 ' headers
    Dim n As Long
    For i = 2 To srCount
        For n = 0 To Data(i, scCount)
            k = k + 1
            For j = 1 To dcCount
                If j <> sepCol Then
                    Result(k, j) = Data(i, j)
                End If
            Next j
            Result(k, sepCol) = Data(i, sepCol)(n)
         Next n
    Next i
    
    ' Write values from Result Array to Destination Range.
    With wb.Worksheets(dName).Range(dFirst).Resize(, dcCount)
        .Resize(drCount).Value = Result
        ' Clear contents below.
        '.Resize(.Worksheet.Rows.Count - drCount - .Row + 1) _
            .Offset(drCount).ClearContents
    End With
    
End Sub

Copy rows from range and split up cell values

1 Answers

Unpivot Column With Delimited Strings