拆分基于分隔符的单元格值并插入新列

Question

The header should be written to each new column inserted, and the cell value should split by the "," delimiter.

Example:

Before:

Header name	another columns from right...
value1
value1,value2,value3
value1,value2

After:

Header name	Header name	Header name	another columns from right...
value1
value1	value2	value3
value1	value2

So far I tried:

Function multipleValues(colName As String)

    Set Rng = getHeadersRange(colName)

    colNumber = Rng.Columns(Rng.Columns.Count).Column

    ColLtr = Cells(1, colNumber).Address(True, False)
    ColLtr = Replace(ColLtr, "$1", "")

    
    Dim indexOfWord As Integer
    Dim maxValues As Integer
    
    'Find out how many new columns needs to be inserted
    
    Dim item As String, newItem As String
    Dim items As Variant, newItems As Variant
    
    maxValues = 0
    
    For Each cell In Rng
    
        items = Split(cell.Value, ",")
        
        If maxValues < UBound(items) Then
            maxValues = UBound(items)
        End If
        
    Next cell
    
    'Insert new columns
    If maxValues > 0 Then
        Columns(Rng.Column).Offset(, 1).Resize(, maxValues).Insert
    End If
    
    'Duplicate the header to the new columns
    
    'For i = 1 To maxValues
    
        'Cells(1, ColLtr + i).Value = colName

    'Next i
    
    'Split the items to columns

    For Each cell In Rng
    
        items = Split(cell.Value, ",")
        maxValues = UBound(items)
        
        For i = 0 To UBound(items)
        
            firstValue = items(0)
            cell.Offset(0, i) = items(i)
            cell.Value = firstValue
            
        Next i
    
    Next cell
    
 
End Function

Currently, I get the new columns with their values except for the header row values.

Answer 1

I would do the following:

First find out how many columns need to be added. We do that by counting the delimiters (commas) in the column and use the maximum + 1 to get the amount of columns we will have in the end after splitting.

Then we read the data of the column into a Data array for faster processing and prepare an Output array in the calculated size.

Then we multiply the header to the Output array and split the data rows into the output array.

Finally we just need to add the right amount of columns to the right and fill in the data from our array.

done.

Option Explicit

Public Sub Example()
    ExpandColumnByDelimiter Columns(1), ","
End Sub

Public Sub ExpandColumnByDelimiter(ByVal ColumnToExpand As Range, Optional ByVal Delimiter As String = ",")
    Dim ws As Worksheet
    Set ws = ColumnToExpand.Parent
    
    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, ColumnToExpand.Column).End(xlUp).Row
    
    ' get data address for formula
    Dim DataAddress As String
    DataAddress = ColumnToExpand.Resize(RowSize:=LastRow - 1, ColumnSize:=1).Offset(RowOffset:=1).Address(True, True, xlA1, True)
    
    ' get max number of columns for output
    Dim MaxColumns As Long
    MaxColumns = Evaluate("=MAX(LEN(" & DataAddress & ")-LEN(SUBSTITUTE(" & DataAddress & ",""" & Delimiter & ""","""")))") / Len(Delimiter) + 1
    
    ' read column data into array
    Dim Data() As Variant
    Data = ColumnToExpand.Resize(RowSize:=LastRow).Value
    
    ' prepare output array
    Dim Output() As Variant
    ReDim Output(1 To LastRow, 1 To MaxColumns) As Variant
    
    ' multiply header
    Dim iHeader As Long
    For iHeader = 1 To MaxColumns
        Output(1, iHeader) = Data(1, 1)
    Next iHeader
    
    ' split data into output array
    Dim SplitData() As String
    Dim iRow As Long
    For iRow = LBound(Data, 1) + 1 To UBound(Data, 1)
        SplitData = Split(Data(iRow, 1), Delimiter)
        
        Dim iCol As Long
        For iCol = LBound(SplitData) To UBound(SplitData)
            Output(iRow, iCol + 1) = SplitData(iCol)
        Next iCol
    Next iRow
    
    ' add new columns to the sheet
    ColumnToExpand.Offset(ColumnOffset:=1).Resize(ColumnSize:=MaxColumns - 1).Insert xlShiftToRight
    
    ' write the data
    ColumnToExpand.Resize(RowSize:=UBound(Output, 1), ColumnSize:=UBound(Output, 2)).Value = Output
End Sub

To turn this

into this

---

/// Edit

And well of course as Siddharth Rout pointed out correcty you can still use the text to column feature if you add in the blank columns that are needed to expand the data. In the end this method would be more efficient.

Public Sub ExpandColumnByDelimiter(ByVal ColumnToExpand As Range, Optional ByVal Delimiter As String = ",")
    Dim ws As Worksheet
    Set ws = ColumnToExpand.Parent
    
    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, ColumnToExpand.Column).End(xlUp).Row
    
    ' get data address for formula
    Dim DataAddress As String
    DataAddress = ColumnToExpand.Resize(RowSize:=LastRow - 1, ColumnSize:=1).Offset(RowOffset:=1).Address(True, True, xlA1, True)
    
    ' get max number of columns for output
    Dim MaxColumns As Long
    MaxColumns = Evaluate("=MAX(LEN(" & DataAddress & ")-LEN(SUBSTITUTE(" & DataAddress & ",""" & Delimiter & ""","""")))") / Len(Delimiter) + 1
        
    ' add new columns to the sheet
    ColumnToExpand.Offset(ColumnOffset:=1).Resize(ColumnSize:=MaxColumns - 1).Insert xlShiftToRight
    
    ' text to column
    ColumnToExpand.Resize(RowSize:=LastRow - 1, ColumnSize:=1).Offset(RowOffset:=1) _
        .TextToColumns Destination:=ColumnToExpand.Cells(2, 1), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False,  Other:=True, OtherChar:=Delimiter
        
    ' multiply header
    ColumnToExpand.Cells(1, 1).Resize(ColumnSize:=MaxColumns).Value = ColumnToExpand.Cells(1, 1).Value
End Sub

Answer 2

Try this (works only in Excel 365). First section of function should be your delimiter with double quotes and second section should be your range.

Function PC_Split(a As String, b As String)
Dim Text() As String
Text = Split(b, a)
PC_Split = Text
End Function