Separate words in a single cell into multiple individual cells?

alexli1219 

You may try the following code to split the data in the desired format.

Sub SplitData()
Dim wsData As Worksheet, wsOutput As Worksheet
Dim lr As Long, lc As Long, i As Long, ii As Long, j As Long
Dim x, y()
Dim str() As String

Application.ScreenUpdating = False

Set wsData = Worksheets("Sheet1")   'Sheet with raw data in Column A
lr = wsData.Cells(Rows.Count, 1).End(xlUp).Row

On Error Resume Next
Set wsOutput = Worksheets("Output") 'Outupt Sheet
wsOutput.Cells.Clear
On Error GoTo 0

If wsOutput Is Nothing Then
    Set wsOutput = Worksheets.Add(after:=wsData)
    wsOutput.Name = "Output"
End If

x = wsData.Range("A1:A" & lr).Value
ReDim y(1 To lr, 1 To 1)
For i = 1 To UBound(x, 1)
    str = Split(x(i, 1), ";")
    j = 1
    If UBound(y, 2) < (UBound(str) + 1) * 2 Then ReDim Preserve y(1 To lr, 1 To (UBound(str) + 1) * 2)
    For ii = LBound(str) To UBound(str)
        y(i, j) = Split(str(ii), "=")(0)
        y(i, j + 1) = Split(str(ii), "=")(1)
        j = j + 2
    Next ii
Next i

wsOutput.Range("A2").Resize(lr, UBound(y, 2)).Value = y
lc = wsOutput.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

For i = 1 To lc Step 2
    wsOutput.Cells(1, i) = "Name"
    wsOutput.Cells(1, i + 1) = "Trait"
Next i

wsOutput.UsedRange.Columns.AutoFit
wsOutput.Select

Application.ScreenUpdating = True
End Sub

Please click the button called "Split Data" on Sheet1 to run the code.