Macro for splitting data into rows

ERoss

New Member
Joined
Nov 29, 2012
Messages
2
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.
EmployeeAccount

<colgroup><col width="175"></colgroup><tbody>
</tbody>
Goals

<colgroup><col width="568"></colgroup><tbody>
</tbody>
1
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.~

<colgroup><col width="568"></colgroup><tbody>
</tbody>
2
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.
~

<colgroup><col></colgroup><tbody>
</tbody>

<tbody>
</tbody>

Would look like this:
EmployeeAccount
Goals

<tbody>
</tbody>
1
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.
1
Deepen overall knowledge of Foundation by attending at least six Foundation team meetings outside of main responsibilities by December 2012.
1
Serve as primary event contact for third party auctions.

<tbody>
</tbody>
...and so on.

Thank YOU!!!!!!!!
 

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".
The following will replace columns A and B with the new format. Please let me know if this works for you.

Code:
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
 
Last edited:
Upvote 0
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.

Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,560
Messages
6,114,309
Members
448,564
Latest member
ED38

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top