CODEWITHSUNDEEP
excelvba
matthoc
matthoc

Reputation: 11

Copy rows from range and split up cell values

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!

Upvotes: 1

Views: 157

Answers (1)

VBasic2008
VBasic2008

Reputation: 54863

Split Column With Delimited Strings

  • Adjust the values in the constants section.

The Code

Option Explicit

Sub SplitColumn()
    
    ' 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

Upvotes: 0

Related Questions