Excel VBA Text To Column

This is what I currently have:

H101    John Doe    Jane Doe    Jack Doe    
H102    John Smith  Jane Smith  Katie Smith Jack Smith

And here is what I want:

H10开发者_C百科1    John Doe
H101    Jane Doe
H101    Jack Doe
H102    John Smith
H102    Jane Smith
H102    Katie Smith
H102    Jack Smith

Obviously I want to do this on a bigger scale. The number of columns is between 1 & 6, so I cant limit it that way. I was able to get a script that allows me to put each individual on one row. However, I am having a hard time getting the first column to copy over to each row.

Sub ToOneColumn()
Dim i As Long, k As Long, j As Integer
Application.ScreenUpdating = False
Columns(2).Insert
i = 0
k = 1
While Not IsEmpty(Cells(k, 3))
    j = 3
    While Not IsEmpty(Cells(k, j))
        i = i + 1
        Cells(i, 1) = Cells(k, 1) //CODE IN QUESTION
        Cells(i, 2) = Cells(k, j)
        Cells(k, j).Clear
        j = j + 1
    Wend
    k = k + 1
Wend
Application.ScreenUpdating = True
End Sub

Like I said, it was working fine to get everyone each on their own row, but can't figure out how to get that first column. It seems like it should be so simple, but it's bugging me. Any help is greatly appreciated.

---

I think you're writing over your data in column 1. You create a new column for the names but not for the first column, though it depends on exactly what your original format is.

Try this:

Sub ToOneColumn()
Dim i As Long, k As Long, j As Integer
Application.ScreenUpdating = False
Columns(2).Insert
Columns(2).Insert
i = 0
k = 1
While Not IsEmpty(Cells(k, 3))
    j = 4
    While Not IsEmpty(Cells(k, j))
        i = i + 1
        Cells(i, 2) = Cells(k, 1) //CODE IN QUESTION
        Cells(i, 3) = Cells(k, j)
        Cells(k, j).Clear
        j = j + 1
    Wend
    k = k + 1
Wend
Application.ScreenUpdating = True
End Sub

Then delete all but the two created columns.