Macro that splits content from cell if given character is found

[andrei]

I give my example :

Column A : book titles
Column B : authors ( a book may have 1 or more authors which ar
separated by a comma - like this : *John Doe , Michael Moore*

Column C , D ,E etc ... information regarding the titles which makes n
difference

The macro should read every cell in B column . If no comma is foun
means it is only one author . Macro should copy the content from tha
cell ( B1 ... Bn) to H column ( H1 ... Hn )

If 1 comma or more are found , means there are more authors . 1 comm
means there are 2 authors , 2 commas means there are 3 authors ... so o


Say there are 2 commas . The Macro should create 2 rows after the ro
analysed with same content . More than that , should put i
corresponding H column the authors one by one . Example


A1: The fugitive B1 : John Doe , Michael Moore , Sasha Wild

The macro should to this :

A1: The fugitive B1 : John Doe , Michael Moore , Sasha Wild H1
John Doe
A2: The fugitive B2 : Jonh Doe , Michael Moore , Sasha Wild H2
Michael Moore
A3: The fugitive B3 : Jonh Doe , Michael Moore , Sasha Wild H3
Sasha Wild


The row number 2 ( A2 , B2 ... ) becomes row number 4 ( A4, B4 ...
after macro does his job . Of course , it is also analysed by macro an
so on till macro find rows without text where it stops

Can this be done

 

[muddan madhu]

Sub text_sep()
Dim r As Integer, i As Integer
Dim counter As Integer, k As Integer
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
r = Cells(Rows.Count, "B").End(xlUp).Row

For i = r To 1 Step -1
j = Split(Cells(i, "B").Value, ",")
counter = UBound(j)
If counter > 0 Then
Range("A" & i + 1 & ":H" & i + counter).Select
Selection.Insert Shift:=xlDown
Range("A" & i & ":H" & i + counter).FillDown
End If
l = i
For k = 0 To counter
Cells(l, "H").Value = Trim(j(k))
l = l + 1
Next k
Next i

With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub

 

[Wen]

An alternative.
I did some quick test but did not write error handling. Let me know if you
have issues.
Option Explicit
Sub SplitAuthor()

Dim Authors() As String
Dim WorkRange As Range, TempRange As Range
Dim i As Integer, NumAuthor As Integer
Application.ScreenUpdating = False
'Define the work range
'I assume your first book title resides in A1. You can make change to the
next line if otherwise.
Set WorkRange = Range("a1")
Do While Not IsEmpty(WorkRange) 'loop through all book titles
Authors = (Split(WorkRange.Offset(0, 1).Value, ","))
NumAuthor = UBound(Authors) 'the number of authors: 0=single author

'if more than one author add new lines and fill down data
If NumAuthor > 0 Then
Range(WorkRange.Offset(1, 0), WorkRange.Offset(NumAuthor,
0)).EntireRow.Insert
Range(WorkRange, WorkRange.Offset(NumAuthor, 1)).EntireRow.FillDown
End If

'copy the author name into column H
Range(WorkRange.Offset(0, 7), WorkRange.Offset(NumAuthor, 7)).Value _
= Application.WorksheetFunction.Transpose(Authors)
For Each TempRange In Range(WorkRange.Offset(0, 7), _
WorkRange.Offset(NumAuthor, 7))
TempRange.Value = Trim(TempRange.Value)
Next TempRange

'go to the next book title
Set WorkRange = WorkRange.Offset(NumAuthor + 1, 0)
Loop

Application.ScreenUpdating = True
End Sub








Sub text_sep()
Dim r As Integer, i As Integer
Dim counter As Integer, k As Integer
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
r = Cells(Rows.Count, "B").End(xlUp).Row

For i = r To 1 Step -1
j = Split(Cells(i, "B").Value, ",")
counter = UBound(j)
If counter > 0 Then
Range("A" & i + 1 & ":H" & i + counter).Select
Selection.Insert Shift:=xlDown
Range("A" & i & ":H" & i + counter).FillDown
End If
l = i
For k = 0 To counter
Cells(l, "H").Value = Trim(j(k))
l = l + 1
Next k
Next i

With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub

 

[andrei]

Just tested muddan madhu macro and it is working ( a brief glance ) .
Thanks !