Convert Single Column into Multiple Rows with VBA

[LiebeDog]

I love this forum.

I have a long list of data in column A that needs to be converted to rows. As you can see in the example, the data in column A has varying data. Some rows have only 3 pieces of information while others have up to 5. I dont know VBA at all. Other than how to run scripts. Does anyone have code I can use. I have Excel 2013. This spreadsheet has north of 100,000 rows of data in Column A. Thank you in advance for help!

BEFORE:

ORIGINAL TEXT

BREAK

Name One

email@aol.com

Komarek School District #94

Hickory Hills, IL

BREAK

Name Two

email@sbcglobal.net

Orland Park, IL

BREAK

Name Three

email@yahoo.com

Community High School District #155

School Psychologist

Elk Grove Village, IL

BREAK

Name Four

email@ladse.org

Lagrange Area Dept. of S.E.

Batavia, IL

BREAK

Name Five

email@nl.edu

National-Louis University

Highwood, IL

BREAK

Name Six

email@aol.com

Franklin Park, IL

BREAK

Name Seven

email@gmail.com

Winnebago, IL

BREAK

Name Eight

email@sbcglobal.net

Chicago Public Schools

School Psychologist

Chicago, IL

BREAK AFTER: Full Name Email Address Company Title City and State Name One email@aol.com Komarek School District #94 Hickory Hills, IL Name Two email@sbcglobal.net Orland Park, IL Name Three email@yahoo.com Community High School District #155 School Psychologist Elk Grove Village, IL Name Four email@ladse.org Lagrange Area Dept. of S.E. Batavia, IL Name Five email@nl.edu National-Louis University Highwood, IL Name Six email@aol.com Franklin Park, IL Name Seven email@gmail.com Winnebago, IL Name Eight email@sbcglobal.net Chicago Public Schools School Psychologist Chicago, IL <tbody> </tbody>

<tbody>
</tbody>

 

[VBA Geek]

Are Name, E-Mail and City-State always going to be there?
Also is there a pattern that can identify whether a line belongs to "Comapny" or "Title"?

 

[Rick Rothstein]

In addition to VBA Geek's questions, I have a couple of my own...

1) What cell is "Name One" from your posted example in... A1, A2 or A3? In other words, is "ORIGINAL TEXT" in cell A1 or is that just a description you added for your posting

2) Is the work "BREAK" actually in the cells or is that just a "marker" indication the cell is empty?

3) Where did you want the output to go... over top of the original data or onto another sheet (if so, which one and what sheet is the data on then)?

 

[LiebeDog]

Perhaps this screen shot will help? This is exactly as it is in Excel. On the left is the original. On the right is the example of how i want it to look after running the VBA script. I color coded the 'BREAK' just in case i have to manipulate the data further.

Hope this helps: https://drive.google.com/file/d/0BwXZ2Gl6tsm-aFJvczBtUjVpc2c/edit?usp=sharing

 

[Rick Rothstein]

Perhaps this screen shot will help? This is exactly as it is in Excel. On the left is the original. On the right is the example of how i want it to look after running the VBA script. I color coded the 'BREAK' just in case i have to manipulate the data further.

Hope this helps:

Your picture did not post correctly (it may be the wrong format). If you want to post a screen shot of part of your worksheet, use one of the add-ins listed in my signature line below.

 

[LiebeDog]

Hi Rick...i i corrected it. Hope this helps. https://drive.google.com/file/d/0BwXZ2Gl6tsm-aFJvczBtUjVpc2c/edit?usp=sharing

 

[Rick Rothstein]

See if this macro does what you want...

Sub RearrangeData()
  Dim Data As Range, A As Range
  Columns("A").Replace "BREAK", "=BREAK", xlWhole
  Set Data = Columns("A").SpecialCells(xlConstants)
  Application.ScreenUpdating = False
  For Each A In Data.Areas
    If A.Count > 2 Then
      A(1).Offset(, 2).Resize(, A.Count) = WorksheetFunction.Transpose(A)
      If A.Count = 3 Then
        A(1).Offset(, 4).Cut A(1).Offset(, 6)
      ElseIf A.Count = 4 Then
        A(1).Offset(, 5).Cut A(1).Offset(, 6)
      End If
    End If
  Next
  Intersect(Columns("C:G"), Range("C1:C" & Cells(Rows.Count, "A"). _
     End(xlUp).Row).SpecialCells(xlBlanks).EntireRow).Delete xlShiftUp
  Columns("A").Replace "=BREAK", "BREAK", xlWhole
  Application.ScreenUpdating = True
End Sub