Macro for splitting data into rows

[ERoss]

Hey Everyone, I've tried to answer this on my own, without any success, so I come to you wonderful Excel masters...

I have a simple spreadsheet with two columns, the A row contains the ID of the person and the B row contains their goals (1-6 or so) which I have exported from sharepoint. Unfortunately, they are massive (and some have line breaks or other characters), but concatenated with a ~. I want to split them into multiple rows for each goal with the ID being copied for each new row created.

Hopefully this snippet helps, this is the source and the second one is what I would like it to look like after running the macro.
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][TABLE="width: 175"]
<colgroup><col width="175"></colgroup><tbody>[TR]
[TD="width: 175"]EmployeeAccount
[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 568"]
<colgroup><col width="568"></colgroup><tbody>[TR]
[TD="width: 568"]Goals
[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD][TABLE="width: 568"]
<colgroup><col width="568"></colgroup><tbody>[TR]
[TD="class: xl65, width: 568"]Serve as Project Manager for at least two 2013 events including: developing budgets, managing staff work plan, leading weekly event meetings, serving as main contact for vendors, and being recognized by peers as the staff lead on the event due to familiarity with details.~Deepen overall knowledge of Foundation by attending at least six Foundation team meetings outside of main responsibilities by December 2012.~Serve as primary event contact for third party auctions.~Enhance event marketing technical skills by taking one professional development course specific to design by December 2012.~
[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD][TABLE="width: 568"]
<colgroup><col></colgroup><tbody>[TR]
[TD]Goal/Objective: Promote industry image and community engagement through recognition programs, strategic partnerships and Association lead community campaigns.
• Create tools and provide resources to implement new program
o Measure of Success: program up and running in four to five cities and a tool kit is produced for others states to implement in their communities.
• Continue to support and promote partner relationships
o Measure of Success: The Association recruits three to four new partners
~Goal/Objective: Identify and promote industry leadership in the area of social responsibility
• Organize two webinars with at least 25 participants on issues related to community relations and philanthropy for Association members.
• Create industry imperative report on social responsibility
• Create one to two white papers on topics rel
• Create a list serv and/or group of industry professionals to discuss issues relevant to community relastions and philanthropy in the industry
~Goal/Objective: Raise funds for RAF
• Golf Invitational
• Measure of Success: Tournaments raises $500,000 to support the RAF Fund; increase number of players from 60 – 72 and increase number of sponsors to 30.
~ Goal/Objective: Work with IT Department to find winners
o Measure of Success: Winners contact information is included in database.
~
[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
</tbody>[/TABLE]

Would look like this:[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]EmployeeAccount
[/TD]
[TD][TABLE="width: 568"]
<tbody>[TR]
[TD="width: 568"]Goals
[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]Serve as Project Manager for at least two 2013 events including: developing budgets, managing staff work plan, leading weekly event meetings, serving as main contact for vendors, and being recognized by peers as the staff lead on the event due to familiarity with details.
[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]Deepen overall knowledge of Foundation by attending at least six Foundation team meetings outside of main responsibilities by December 2012.
[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]Serve as primary event contact for third party auctions.
[/TD]
[/TR]
</tbody>[/TABLE]
...and so on.

Thank YOU!!!!!!!!

 

[jeffmb]

The following will replace columns A and B with the new format. Please let me know if this works for you.

Option Explicit
Dim i As Integer
Dim r As Integer
Dim c As Long
Dim l As Integer
Dim flg As Integer
Dim lastrow As Integer
Sub find_it()
    Application.ScreenUpdating = False
    r = 1
    lastrow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastrow
        flg = 0
        Do While flg = 0
            c = InStr(Sheets("Sheet1").Range("B" & i).Value, "~")
            l = Len(Sheets("Sheet1").Range("B" & i).Value)
            If c = 0 Then
                If l > 0 Then
                    Range("C" & r).Value = Range("A" & i).Value
                    Range("D" & r).Value = Range("B" & i).Value
                    r = r + 1
                End If
                flg = 1
            Else
                Range("C" & r).Value = Range("A" & i).Value
                Range("D" & r).Value = Left(Range("B" & i).Value, c - 1)
                Range("B" & i).Value = Right(Range("B" & i).Value, l - c)
                r = r + 1
            End If
        Loop
    Next
    
    Columns("A:B").Select
    Selection.Delete Shift:=xlToLeft
    Columns("B:B").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.ColumnWidth = 50
    Cells.Select
    Cells.EntireRow.AutoFit
    Application.ScreenUpdating = True
End Sub

 

[ERoss]

Works like a champ, jeffmb.

Thank you very much, you probably saved my job by taking the time to help today.

The following will replace columns A and B with the new format. Please let me know if this works for you.

Option Explicit
Dim i As Integer
Dim r As Integer
Dim c As Long
Dim l As Integer
Dim flg As Integer
Dim lastrow As Integer
Sub find_it()
    Application.ScreenUpdating = False
    r = 1
    lastrow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastrow
        flg = 0
        Do While flg = 0
            c = InStr(Sheets("Sheet1").Range("B" & i).Value, "~")
            l = Len(Sheets("Sheet1").Range("B" & i).Value)
            If c = 0 Then
                If l > 0 Then
                    Range("C" & r).Value = Range("A" & i).Value
                    Range("D" & r).Value = Range("B" & i).Value
                    r = r + 1
                End If
                flg = 1
            Else
                Range("C" & r).Value = Range("A" & i).Value
                Range("D" & r).Value = Left(Range("B" & i).Value, c - 1)
                Range("B" & i).Value = Right(Range("B" & i).Value, l - c)
                r = r + 1
            End If
        Loop
    Next
    
    Columns("A:B").Select
    Selection.Delete Shift:=xlToLeft
    Columns("B:B").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.ColumnWidth = 50
    Cells.Select
    Cells.EntireRow.AutoFit
    Application.ScreenUpdating = True
End Sub