Multi Line Text to Multiple Columns

[hl2qs]

I have a number of contacts with their details on individual lines in Column A like this in Excel 2010, Windows 7:

Bob Smith
165 Cresap
Charlottesville, VA
E bob@virginia.edu

Jane Woodard
119 Stadium Road
Scottsville, VA
E jane@jmu.edu

I was hoping to be able convert them to multiple columns, with the names in one column, the address in another, etc. Any ideas on how to do this in a couple steps?

Much obliged
Hamilton

 

[djreiswig]

Something like this? Might need a little tweaking, but I don't have time right now.

    Range("A:A").TextToColumns Destination:=Range("A:A"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :=Chr$(10), FieldInfo:=Array(1, 1)

 

[hl2qs]

Thanks, it looks good, but Excel doesn't seem to like it. Text to Column works with the email addresses since I managed to put an E in front of them, but I do need the names to match. If there was a way to separate the names into a column, maybe using the space above them, then the job would be done.

 

[djreiswig]

Is

Bob Smith
165 Cresap
Charlottesville, VA
E bob@virginia.edu

is cell A1 or is each line a different row? Also, when I copy and paste this into Excel the e-mail address isn't a link anymore. Maybe that has something to do with it.

You did put the code in a vba module sub and run it from there, correct?

 

[mirabeau]

I have a number of contacts with their details on individual lines in Column A like this in Excel 2010, Windows 7:

Bob Smith
165 Cresap
Charlottesville, VA
E bob@virginia.edu

Jane Woodard
119 Stadium Road
Scottsville, VA
E jane@jmu.edu

I was hoping to be able convert them to multiple columns, with the names in one column, the address in another, etc. Any ideas on how to do this in a couple steps?

Much obliged
Hamilton

If data start from A1

Sub transp()
Dim e As Range, g As Range, k As Long
Set e = Range("A1")
Do
    Set g = Range(e, e.End(4))
    k = k + 1
    Range("D" & k).Resize(, g.Rows.Count) = Application.Transpose(g)
    If e.End(4).End(4).Row = Rows.Count Then Exit Do
    Set e = e.End(4).End(4)
Loop
End Sub

 

[Rick Rothstein]

Thanks, it looks good, but Excel doesn't seem to like it. Text to Column works with the email addresses since I managed to put an E in front of them, but I do need the names to match. If there was a way to separate the names into a column, maybe using the space above them, then the job would be done.

This macro should do what you want and you do not need the "E " in front of the email address for it to work (the email addresses will remain "active" hyperlinks)...

Sub TransposeData()
  Dim LastRow As Long, A As Range
  Const StartRow As Long = 1
  Const DataCol As String = "A"
  LastRow = Cells(Rows.Count, DataCol).End(xlUp).Row
  For Each A In Cells(StartRow, DataCol).Resize(LastRow - StartRow + 1).SpecialCells(xlCellTypeConstants).Areas
    A(1).Resize(, A.Rows.Count - 1) = WorksheetFunction.Transpose(A.CurrentRegion)
    A(1)(A.Rows.Count).Copy Cells(A(1).Row, A(1).Offset(, A.Rows.Count - 1).Column)
  Next
  Cells(StartRow, DataCol).Offset(, 1).Resize(LastRow - StartRow + 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

You can change the data start row and the data column via the constant (Const) statements at the top of the macro if your data does not start in cell A1. Also, each of your data sections do not need to contain the same number of rows as long as the last row is always the email address.

 

[hl2qs]

Thanks everybody, the macros definitely made sorting my contacts on Excel easier. Some extra blank spaces between the contacts threw off the macros, but they saved me a good deal of time. Thanks

 

[Rick Rothstein]

Thanks everybody, the macros definitely made sorting my contacts on Excel easier. Some extra blank spaces between the contacts threw off the macros, but they saved me a good deal of time. Thanks

See if this modification to my originally posted code handles your data where each group of data may have one or more empty cells separating them...

Sub TransposeData()
  Dim LastRow As Long, A As Range
  Const StartRow As Long = 1
  Const DataCol As String = "A"
  LastRow = Cells(Rows.Count, DataCol).End(xlUp).Row
  For Each A In Cells(StartRow, DataCol).Resize(LastRow - StartRow + 1).SpecialCells(xlCellTypeBlanks).Areas
    If A.Count > 1 Then A.Offset(1).Resize(A.Count - 1).Value = "#N/A"
  Next
  Columns("A").SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
  For Each A In Cells(StartRow, DataCol).Resize(LastRow - StartRow + 1).SpecialCells(xlCellTypeConstants).Areas
    A(1).Resize(, A.Rows.Count - 1) = WorksheetFunction.Transpose(A.CurrentRegion)
    A(1)(A.Rows.Count).Copy Cells(A(1).Row, A(1).Offset(, A.Rows.Count - 1).Column)
  Next
  Cells(StartRow, DataCol).Offset(, 1).Resize(LastRow - StartRow + 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub