Splitting Cell content into separate Rows

[JokerFrowns]

I have a Spreadsheet that looks like the following,

Name Order Date Order
John Smith 06/05/14 A,B,C,D
Mike Doe 06/02/26 B,C,E

and so on... with several thousand entries.

I need the database to be structured in the following way.

Name Order Date Order
John Smith 06/05/14 A
John Smith 06/05/14 B
John Smith 06/05/14 C
John Smith 06/05/14 D
Mike Doe 06/02/26 B
Mike Doe 06/02/26 C
Mike Doe 06/02/26 E

Is there any way that I can make this happen using a macro or applet of
some sort? Does anyone have one that will do this already?
Things to note are that all orders are currently separated by a comma
followed by a single space, these must be removed.

If anyone can help, thanks in advance.

 

[Ikaabod]

It isn't pretty, but it works.

Sub SplitSeparate()
Application.ScreenUpdating = False
Dim r As Integer, r2 As Integer
Dim c As Integer, c2 As Integer
r = 0
r2 = 0
c = 3
c2 = 0
Columns("C:C").Select
Selection.TextToColumns Destination:=Range("C1")
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True
Tab:=True, _
Semicolon:=False, Comma:=True, Space:=True, Other:=False
FieldInfo:= _
Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1))
TrailingMinusNumbers:= _
True

Range("A2").Select
Do
Do
If IsEmpty(ActiveCell.Offset(r, c)) = False Then
r2 = r2 + 1
ActiveCell.Offset(r2, 0).EntireRow.Insert
Range(ActiveCell.Offset(r, 0), ActiveCell.Offset(r, c)).Copy
Range(ActiveCell.Offset(r2, 0).Address).PasteSpecial
Range(ActiveCell.Offset(0, c).Address).Copy
Range(ActiveCell.Offset(0, 2).Address).PasteSpecial
Application.CutCopyMode = False
c = c + 1
Else
c = c + 1
r2 = r2 + 1
End If
ActiveCell.Offset(-r2, -2).Activate
Loop Until IsEmpty(ActiveCell.Offset(r, c)) = True
r = r2
ActiveCell.Offset(r + 1, 0).Activate
r = 0
r2 = 0
If c > c2 Then c2 = c
c = 3
Loop Until IsEmpty(ActiveCell) = True
Range("D1", ActiveCell.Offset(0, c2
1).Address).EntireColumn.ClearContents
Application.ScreenUpdating = True
End Sub

 

[JokerFrowns]

Many thanks,

I am no excel buff, do I just insert this into the code console and
away I go?

 

[Ikaabod]

In excel you can hit alt-F11, then click INSERT->MODULE and paste the
code in there. You can run the code a number of ways (i.e. - create a
command button that runs the macro, or manually run it in Microsoft VB
Editor, etc.) Let me know if you have problems.

 

[Ikaabod]

There is one thing that needs changed actually. Change:
ActiveCell.Offset(-r2, -2).Activate
to
If ActiveCell.Column <> 1 Then ActiveCell.Offset(-r2, -2).Activate

 

[JokerFrowns]

I am getting an error compiling syntax in the following line:

Selection.TextToColumns Destination:=Range("C1"),

Am I doing something wrong or forgetting something?

 

[JokerFrowns]

Ikaabod, I'm sure I was not explicit enough in my original issue...

Columns A through H are all single data entries that need to be
repeated while it is Column I that contains the items separated by
commas. Additionally there is a column J that contains data that is
never to be repeated or split, as well as a column K that is to be
repeated in the same manner as A through H for the database.

Sorry if I was not specific in the first place, I wasn't expecting to
have someone come out and give me such excellent help, nevermind code.

Please help further if possible.

 

[Ikaabod]

Let's try this one out:

Sub Separate()
Application.ScreenUpdating = False
Dim i As Integer
Dim rng As String, rng2 As String
Dim MyStart As String
MyStart = ActiveCell.Address
Dim Sht As Worksheet
Set Sht = ActiveSheet
Sheets.Add.Name = "TempForm"
Sht.Range("A:I").Copy
Sheets("TempForm").Range("A1").PasteSpecial
Sht.Range("K:K").Copy
Sheets("TempForm").Range("I1").Insert
Application.CutCopyMode = False
Range("J:J").Select
Selection.TextToColumns Destination:=Range("J1"),
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=True, Other:=False, FieldInfo:=
_
Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)),
TrailingMinusNumbers:= _
True
Dim rLast As Integer
rLast = ActiveSheet.UsedRange.Rows.Count
Range("K" & rLast).Select
Do
If IsEmpty(ActiveCell) Then
ActiveCell.Offset(-1, 0).Activate
Else
ActiveCell.Offset(1, 0).EntireRow.Insert
ActiveCell.Copy
rng = ActiveCell.Address
ActiveCell.Offset(1, -1).PasteSpecial
Range(rng).Select
Selection.Delete
Range(ActiveCell.Offset(0, -10).Address, ActiveCell.Offset(0,
-2).Address).Copy
ActiveCell.Offset(1, -10).PasteSpecial
Range(rng).Select
End If
Loop Until ActiveCell.Address = "$K$1"
Range("I:I").Copy
Range("L1").PasteSpecial
Range("I1").EntireColumn.Delete
Range("A:I").Copy
Sheets(Sht.Name).Activate
Range("A1").Select
Selection.PasteSpecial xlValues
Sheets("TempForm").Range("K:K").Copy
Range("K1").Select
Selection.PasteSpecial xlValues
Application.DisplayAlerts = False
Sheets("TempForm").Delete
Application.DisplayAlerts = True
Range(MyStart).Select
Application.ScreenUpdating = True
End Sub

 

[JokerFrowns]

Seems to be working great except for one minor issue which I think can
be solved by an integer count possibly... the datatable starting as:
for example

A B C D E F G H I J
K
1 2 3 4 5 6 7 8 9i, 9ii, 9iii
10 11
a b c d e f g h ii,iii,iiii
j k

is being split in the following manner...

A B C D E F G H I J K
1 2 3 4 5 6 7 8 9i 10
11
1 2 3 4 5 6 7 8 9ii j
11
1 2 3 4 5 6 7 8 9iii
11
a b c d e f g h ii
k
a b c d e f g h iii
k
a b c d e f g h iiii
k

When infact what I need it to be doing is...

A B C D E F G H I J K
1 2 3 4 5 6 7 8 9i 10
11
1 2 3 4 5 6 7 8 9ii
11
1 2 3 4 5 6 7 8 9iii
11
a b c d e f g h ii j
k
a b c d e f g h iii
k
a b c d e f g h iiii
k

Is it possible to modify the code you just gave me to allow for this
type of split? Otherwise it seems to be working exactly as needed.

Once again, many many thanks for all the help.

 

[Ikaabod]

Sub Separate()
Application.ScreenUpdating = False
Dim i As Integer
Dim rng As String, rng2 As String
Dim MyStart As String
MyStart = ActiveCell.Address
Dim Sht As Worksheet
Set Sht = ActiveSheet
Sheets.Add.Name = "TempForm"
Sht.Range("A:K").Copy
Sheets("TempForm").Range("A1").PasteSpecial
Range("J1").EntireColumn.Copy
Range("I1").EntireColumn.Insert
Range("L1").EntireColumn.Copy
Range("I1").EntireColumn.Insert
Range("L:M").EntireColumn.Delete
Range("K:K").Select
Selection.TextToColumns Destination:=Range("K1"),
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=True, Other:=False, FieldInfo:=
_
Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)),
TrailingMinusNumbers:= _
True
Dim rLast As Integer
rLast = ActiveSheet.UsedRange.Rows.Count
Range("L" & rLast).Select
Do
If IsEmpty(ActiveCell) Then
ActiveCell.Offset(-1, 0).Activate
Else
ActiveCell.Offset(1, 0).EntireRow.Insert
ActiveCell.Copy
rng = ActiveCell.Address
ActiveCell.Offset(1, -1).PasteSpecial
Range(rng).Select
Selection.Delete
Range(ActiveCell.Offset(0, -11).Address, ActiveCell.Offset(0,
-3).Address).Copy
ActiveCell.Offset(1, -11).PasteSpecial
Range(rng).Select
End If
Loop Until ActiveCell.Address = "$L$1"
Range("I:I").Copy
Range("L1").PasteSpecial
Range("J:J").Copy
Range("L1").EntireColumn.Insert
Range("I:J").EntireColumn.Delete
Range("A:K").Copy
Sheets(Sht.Name).Activate
Range("A1").Select
Selection.PasteSpecial xlValues
Application.DisplayAlerts = False
Sheets("TempForm").Delete
Application.DisplayAlerts = True
Range(MyStart).Select
Application.ScreenUpdating = True
End Sub

 

[JokerFrowns]

Thank you so much, you have made my life so much easier.

 

[JokerFrowns]

Thank you so much, you have made my life so much easier.

 

[JokerFrowns]

I will test this out on the actual data later on this evening and let
you know how it goes, I have only been testing it on test cases so far
since the real data is on another machine. Hopefully it works. Thanks
again.

 

[Ikaabod]

Glad to help. I hope it works. If you have any issues let me know.
Again, I know it's pretty ugly, but at the very least it should work
Best of luck.