How to split single text cell into multiple rows, using a comma delimiter?

[Bond007]

Hello - could anyone help me? I have a string of text in one cell on Sheet 1 (ie., A1, Sheet 1), here is a excerpt:

A-dec International Inc., A. Bellotti, A. DEPPELER S.A., etc ...

What I need to do is split the cell into separate rows, using the comma as a delimiter. I will be reading the cell from another sheet and need a formula that will provide me with

A1: A-dec International Inc.
A2: A. Bellotti
A3: A. DEPPELER S.A.

Many Thanks!

 

[kevinruairi]

Hey Rick,

Yes that code has worked for me! -- thank you very much!

For the moment, I dont think I will be using this function with much other data.
But if I was to be using it with other raw data in future in different columns, I assume I can just replace the E and F in the above code to suit whatever columns I want to 'pair' up.

But - is there a Macro that would give me a prompt for which columns I wanted to split & pair ?

(Sorry to be greedy!! )

 

[Rick Rothstein]

But if I was to be using it with other raw data in future in different columns, I assume I can just replace the E and F in the above code to suit whatever columns I want to 'pair' up.

But - is there a Macro that would give me a prompt for which columns I wanted to split & pair ?

(Sorry to be greedy!! )

No problem. I have modified the code to ask you for the two column letter designations...

Sub RedistributeData()
  Dim X As Long, LastRow As Long, A As Range, Table As Range, Data1() As String, Data2() As String
  Dim DelimitedColumn1 As String, DelimitedColumn2 As String
  Const Delimiter As String = ","
  Const TableColumns As String = "A:M"
  Const StartRow As Long = 2
  DelimitedColumn1 = InputBox("First delimited column letter designation...")
  If DelimitedColumn1 = "" Or DelimitedColumn1 Like "*[!A-Za-z]*" Then Exit Sub
  DelimitedColumn2 = InputBox("First delimited column letter designation...")
  If DelimitedColumn2 = "" Or DelimitedColumn2 Like "*[!A-Za-z]*" Then Exit Sub
  Application.ScreenUpdating = False
  LastRow = Columns(TableColumns).Find(What:="*", SearchOrder:=xlRows, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row
  For X = LastRow To StartRow Step -1
    Data1 = Split(Cells(X, DelimitedColumn1), Delimiter)
    Data2 = Split(Cells(X, DelimitedColumn2), Delimiter)
    If UBound(Data1) > 0 Then
      Intersect(Rows(X + 1), Columns(TableColumns)).Resize(UBound(Data1)).Insert xlShiftDown
    End If
    If Len(Cells(X, DelimitedColumn1)) Then
      Cells(X, DelimitedColumn1).Resize(UBound(Data1) + 1) = WorksheetFunction.Transpose(Data1)
    End If
    If Len(Cells(X, DelimitedColumn2)) Then
      Cells(X, DelimitedColumn2).Resize(UBound(Data2) + 1) = WorksheetFunction.Transpose(Data2)
    End If
  Next
  LastRow = Cells(Rows.Count, DelimitedColumn1).End(xlUp).Row
  On Error Resume Next
  Set Table = Intersect(Columns(TableColumns), Rows(StartRow).Resize(LastRow - StartRow + 1))
  If Err.Number = 0 Then
    Table.SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    Columns(DelimitedColumn1).SpecialCells(xlFormulas).Clear
    Table.Value = Table.Value
  End If
  On Error GoTo 0
  Application.ScreenUpdating = True
End Sub

 

[kevinruairi]

Thank you very much for that! That is very kind & generous of you.

(I have changed the prompt text in Line 9 of the code to read "Second delimited column letter designation...")

 

[Rick Rothstein]

(I have changed the prompt text in Line 9 of the code to read "Second delimited column letter designation...")

That's what happens when I copy/paste without thinking about what I copy/pasted.

 

[kevinruairi]

Heh, that's ok, we're all human.

Most of us, anyway.

 

[hogbina]

Hello,

I am new to this forum and I apologise for jumping on an old thread but the example provided further back is almost what I am after.

Option Explicit
Sub Splt()
Dim LR As Long, i As Long, LC As Integer
Dim X As Variant
Dim r As Range, iCol As Integer
On Error Resume Next
Set r = Application.InputBox("Click in the column to split by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
Application.ScreenUpdating = False
LC = Cells(1, Columns.Count).End(xlToLeft).Column
LR = Cells(Rows.Count, iCol).End(xlUp).Row
Columns(iCol).Insert
For i = LR To 1 Step -1
With Cells(i, iCol + 1)
If InStr(.Value, ",") = 0 Then
.Offset(, -1).Value = .Value
Else
X = Split(.Value, ",")
.Offset(1).Resize(UBound(X)).EntireRow.Insert
.Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
End If
End With
Next i
Columns(iCol + 1).Delete
LR = Cells(Rows.Count, iCol).End(xlUp).Row
With Range(Cells(1, 1), Cells(LR, LC))
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
On Error GoTo 0
.Value = .Value
End With
Application.ScreenUpdating = True
End Sub

This works but I am unable to work out how I can get the following to happen.
1. The split results to be moved to a new column (eg D) on a new sheet (same workbook)
2. The original results to be left as is (ie not to be deleted)

My VBA skills are basic to say the least so any help or pointers would be very much appreciated.

Thank you in advance.

Alastair

 

[Techdropout]

Hi, thanks for sharing the codes. I replaced column M with E and N with F. But I am getting "=R[-1]C" pasted to fill the new rows instead of the values from the original row being replicated (see example below). Please advise. Thanks.

Field A	Field B	Field C	Field D	Field E	Field F	Field G
Field A	Field B	Field C	Field D	2400001, 2400002, 2400003, 2400004, 2400005	Field F	Field G

<tbody>
</tbody>

Field A	Field B	Field C	Field D	Field E	Field F	Field G
Field A	Field B	Field C	Field D	2400001	Field F	Field G
=R[-1]C	=R[-1]C	=R[-1]C	=R[-1]C	2400002	Field F	=R[-1]C
=R[-1]C	=R[-1]C	=R[-1]C	=R[-1]C	2400003	Field F	=R[-1]C
=R[-1]C	=R[-1]C	=R[-1]C	=R[-1]C	2400004	Field F	=R[-1]C
=R[-1]C	=R[-1]C	=R[-1]C	=R[-1]C	2400005	Field F	=R[-1]C

<tbody>
</tbody>

Sub Splt()
Dim LR As Long, i As Long
Dim X As Variant
Application.ScreenUpdating = False
LR = Range("E" & Rows.Count).End(xlUp).Row
Columns("E").Insert
For i = LR To 1 Step -1
With Range("F" & i)
If InStr(.Value, ",") = 0 Then
.Offset(, -1).Value = .Value
Else
X = Split(.Value, ",")
.Offset(1).Resize(UBound(X)).EntireRow.Insert
.Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
End If
End With
Next i
Columns("F").Delete
LR = Range("E" & Rows.Count).End(xlUp).Row
With Range("A1:G" & LR)
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
On Error GoTo 0
.Value = .Value
End With
Application.ScreenUpdating = True
End Sub

 

[clueless01]

Hello everyone,

I am new to this forum and extremely new to vba. I found this page by searching for a solution on splitting single text cell into multiple rows.
My issue is similar to the OP.

Original Sample from the OP
Example:

Code:

A |B |C
1car, door |mechanical |auto
2fruit, apple |plant |tree
3pie, cherry |dessert |pastry

So that the outcome would look like this:

Code:

A |B |C
1car |mechanical |auto
2door |mechanical |auto
3fruit |plant |tree
4apple |plant |tree
5pie |dessert |pastry
6cherry |dessert |pastry


My sample:

A	B	C
car, motorcycle	mechanical, machine	auto
orange, apple	plant, fruit	tree
cookie, cake	dessert, food	bakery

<tbody>
</tbody>

Needed outcome

A	B	C
car	mechanical	auto
motorcycle	mechanical	auto
car	machine	auto
motorcycle	machine	auto
orange	plant	tree
apple	plant	tree
orange	fruit	tree
apple	fruit	tree
cookie	dessert	bakery
cake	dessert	bakery
cookie	food	bakery
cake	food	bakery

<tbody>
</tbody>

I only need Columns A and B to be split into multiple rows. While leaving the other columns like column C, D, E, F.. and so on to remain the same.

I have read the replies and only saw a solution to the split column A into multiple rows.

This is the solution to the OP
Code:
Sub Splt()
Dim LR As Long, i As Long, LC As Integer
Dim X As Variant
Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row
LC = Cells(1, Columns.Count).End(xlToLeft).Column
Columns("A").Insert
For i = LR To 1 Step -1
With Range("B" & i)
If InStr(.Value, ",") = 0 Then
.Offset(, -1).Value = .Value
Else
X = Split(.Value, ",")
.Offset(1).Resize(UBound(X)).EntireRow.Insert
.Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
End If
End With
Next i
Columns("B").Delete
LR = Range("A" & Rows.Count).End(xlUp).Row
With Range(Cells(1, 2), Cells(LR, LC))
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
On Error GoTo 0
.Value = .Value
End With
Application.ScreenUpdating = True
End Sub

I have tried the above macro and works well for only column A.

Is there a way to tweak this so that it works on column A and column B?

Many thanks to VoG and those who have contributed to this thread.
Thanks in advance!!

 

[ronmun]

Hi,
if you still using this forum, could you please write me code that Include columns A to D? I am using this code and coping down column D manually. Your code helping me a lot right now. But if you can just write me same code with A to D, then i will be really appreciated.

 

[timberlb]

In the code above you handled the question from CharterJace....however, does the same code work if there is a row that is mixed in that does NOT have a comma delimited content? In my example below:

  A                    |B                    |C
1car, door             |mechanical           |auto
2fruit, apple          |plant                |tree
3snake                   |reptile      |animal
4pie, cherry           |dessert              |pastry

does it produce

  A                    |B                    |C
1car                   |mechanical           |auto
2door                  |mechanical           |auto
3fruit                 |plant                |tree
4apple                 |plant                |tree
5snake                   |reptile      |animal  
6pie                   |dessert              |pastry
7cherry                |dessert              |pastry