Separating text of different length in one cell into different columns

Hi everyone,

I am trying to separate text in on cell into different columns. The issue is that the text strings are of different length (might consists of four words, two words, one word or more words). In the current file they are listed on top of each other. In the column next to them there is a numerical code that corresponds to the entries in the first column. If there are three names and three numerical codes in column one and two I would like to separate them in a way that each name and numerical code is in a separate column (this would make a total of six new columns). I have attached a sample of the data to get a better understanding (the first row shows how the data should look at the end ).

Thanks a lot for any comments!

P.s. The text to column does not work as the text string have different lengths.

ExcelKook,

Detach/open workbook Split H I Sp Sp2 vblf - ExcelKook - EF775205 - SDG14.xlsm and run macro SplitHI.



If you want to use the macro on another workbook:


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).


1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub SplitHI()
' stanleydgromjr, 05/08/2011
' http://www.excelforum.com/excel-programming/775205-separating-text-of-different-length-in-one-cell-into-different-columns.html
Dim c As Range, NC As Long, a As Long, aa As Long, LC As Long, CN As String
Dim Sp, Sp2
Application.ScreenUpdating = False
Worksheets("Sheet1").Activate
For Each c In Range("H2", Range("H" & Rows.Count).End(xlUp))
  NC = 9
  If InStr(c, vbLf) = 0 Then
    c.Offset(, 2) = c
    c.Offset(, 3) = c.Offset(, 1)
  Else
    Sp = Split(c, vbLf)
    Sp2 = Split(c.Offset(, 1), vbLf)
    NC = NC + 1
    For a = LBound(Sp) To UBound(Sp)
      Cells(c.Row, NC) = Sp(a)
      Cells(c.Row, NC + 1) = Sp2(a)
      NC = NC + 2
    Next a
  End If
Next c
LC = Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
aa = 1
For a = 10 To LC Step 2
  Cells(1, a).Resize(, 2).Value = [{"Firm","Code"}]
  Cells(1, a).Value = Cells(1, a) & " " & aa
  Cells(1, a + 1).Value = Cells(1, a + 1) & " " & aa
  aa = aa + 1
Next a
CN = Replace(Cells(1, LC).Address(0, 0), 1, "")
Columns("J:" & CN).AutoFit
Application.ScreenUpdating = True
End Sub

Before you use the macro, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm


With your raw data in worksheet Sheet1, then run the SplitHI macro.