Split cell content into multiple rows, retaining adjeacent cell data

[fmassa81]

Folks,

This is my first time posting and am really grateful for any help with my puzzle!

I'm working on a project where I have to count author publications across several academic journals. I have downloaded and organized all the data for these journals, but have been struggling to parse things out for an easy count.

I've been searching the forum for a straightforward way to split semi-colon delimited author names for a single article, create one row per co-author name and carry over the article details to the newly created rows.

My data looks something like this (except that rows continue all the way to column BD):

<tbody> [TD="align: center"]Åstebro,Thomas;Bernhardt,Irwin

<tbody> [TD="align: center"]Basic Statistics on the Success

<tbody>
[TD="align: center"] Authors [/TD]
[TD="align: center"] Number of Authors [/TD]
[TD="align: center"] Title [/TD]
[TD="align: center"] Periodical [/TD]

</tbody>

[/TD]
[TD="align: center"]2[/TD]
[TD="align: center"]The Winner's Curse of Human Capital[/TD]
[TD="align: center"]Small Business Economics[/TD]

[TD="align: center"]Åstebro,Thomas[/TD]
[TD="align: center"]1[/TD]

</tbody>

[/TD]
[TD="align: center"]Entrepreneurship: Theory & Practice[/TD]

[TD="align: center"]Demircan;Erturk,Alper[/TD]
[TD="align: center"]2[/TD]
[TD="align: center"]Technological Change[/TD]
[TD="align: center"]Small Business Economics[/TD]

</tbody>

I would like the data to look like this:

<tbody> [TD="align: center"]Åstebro,Thomas

<tbody> [TD="align: center"]Basic Statistics on the Success

<tbody>
[TD="align: center"] Authors [/TD]
[TD="align: center"] Number of Authors [/TD]
[TD="align: center"] Title [/TD]
[TD="align: center"] Periodical [/TD]

</tbody>

[/TD]
[TD="align: center"]2[/TD]
[TD="align: center"]The Winner's Curse of Human Capital[/TD]
[TD="align: center"]Small Business Economics[/TD]

[TD="align: center"]Bernhardt,Irwin[/TD]
[TD="align: center"]2[/TD]
[TD="align: center"]The Winner's Curse of Human Capital[/TD]
[TD="align: center"]Small Business Economics[/TD]

[TD="align: center"]Åstebro,Thomas[/TD]
[TD="align: center"]1[/TD]

</tbody>

[/TD]
[TD="align: center"]Entrepreneurship: Theory & Practice[/TD]

[TD="align: center"]Demircan;[/TD]
[TD="align: center"]2[/TD]
[TD="align: center"]Technological Change[/TD]
[TD="align: center"]Small Business Economics[/TD]

[TD="align: center"]Erturk,Alper[/TD]
[TD="align: center"]2[/TD]
[TD="align: center"]Technological Change[/TD]
[TD="align: center"]Small Business Economics[/TD]

</tbody>

In short, the author cells are split into multiple rows and all the adjacent data about the articles they co-authored up to Column BD gets carried over to the newly created row. There are a total of 7180 rows in my worksheet. My version of Excel is 2010.

Thank you advance for your help!

 

[venkat1926]

the data is in sheet1 as follows

Excel Workbook
	A	B	C	D
1	Authors	Number of Authors	Title	Periodical
2	stebro,Thomas;Bernhardt,Irwin	2	The Winner's Curse of Human Capital	Small Business Economics
3	stebro,Thomas	1	Basic Statistics on the Success	Entrepreneurship: Theory & Practice
4	Demircan;Erturk,Alper	2	Technological Change	Small Business Economics
Sheet1

run tis macro and see sheet3

Dim r1 As Range, c1 As Range, dest As Range, k As Integer, j As Integer
Dim destr As Range
Sub test()
Set r1 = Range(Range("A2"), Range("A2").End(xlDown))
Set dest = Range("A1").End(xlDown).Offset(5, 0)




With Worksheets("sheet3")
.Cells.Clear
End With
Worksheets("sheet1").Activate




For Each c1 In r1
c1.TextToColumns Destination:=dest, DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
j = Cells(dest.Row, Columns.Count).End(xlToLeft).Column
'MsgBox j
For k = 1 To j


dest.Offset(0, k - 1).Copy
With Worksheets("sheet3")
Set destr = .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
destr.PasteSpecial
End With
Range(c1.Offset(0, 1), c1.End(xlToRight)).Copy
With Worksheets("sheet3")
destr.Offset(0, 1).PasteSpecial
End With


Next k


dest.EntireRow.Cells.Clear
nextc1:
Next c1
With Worksheets("sheet3")
Range(Range("A1"), Range("A1").End(xlToRight)).EntireColumn.AutoFit
End With
MsgBox "macro over"
End Sub