Macro for splitting data into rows

Thanks Thanks:  0
Likes Likes:  0
Results 1 to 3 of 3

Thread: Macro for splitting data into rows

  1. #1
    New Member
    Join Date
    Nov 2012
    Posts
    2
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Macro for splitting data into rows

    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
    Goals
    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.~
    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.
    ~

    Would look like this:
    EmployeeAccount
    Goals
    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.
    ...and so on.

    Thank YOU!!!!!!!!

  2. #2
    Board Regular
    Join Date
    Jul 2008
    Location
    Fort Lauderdale
    Posts
    168
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Macro for splitting data into rows

    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 by jeffmb; Nov 29th, 2012 at 12:40 PM.

  3. #3
    New Member
    Join Date
    Nov 2012
    Posts
    2
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Macro for splitting data into rows

    Works like a champ, jeffmb.

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

    Quote Originally Posted by jeffmb View Post
    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

User Tag List

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  

 

DMCA.com