Take a 3 column list, make it 1 column

[Davers]

Hey everyone. I have a list with name in column A, extension in column B, and level in column . I'd like to combine those to columns into 1. So this:

Name	Extension	Level
Anderson 34888	1
Crawford	34252	1
Fairful     34444	1
Heath	34275	1
Jaffe	68998	1
Kohl	34272	1
Kujawski	16868	1
Lyon	34222	1
Morrison	34257	1
Shamus	34255	1
Skelton	34999	1

Would look like this:

List
Anderson
34888
1
Crawford
34252
1
Fairful
34444
1
Heath
34275
1
Jaffe
68998
1
Kohl
34272
1
Kujawski
16868
1
Lyon
34222
1
Morrison
34257
1
Shamus
34255
1
Skelton
34999
1

VBA would be the preferred method. Any ideas?

Thanks!!

Dave

 

[JackDanIce]

Try:

Sub MachineGunsRock ()
Dim i as Long, j as Long
Application.ScreenUpdating = False
j = 1
For i = 1 to Range("A" & Rows.Count).End(xlUp).Row
  Range("D" & j) = Range("A" & i)
  Range("D" & j + 1) = Range("B" & i)
  Range("D" & j + 2) = Range("C" & i)
  j = j + 3
Next i
Range("A:C").Delete shift:=xlToLeft
Rows("2:3").Delete
Range("A1") = "List"
Application.ScreenUpdating = True
End Sub

 

[MickG]

Try:-

[COLOR="Navy"]Sub[/COLOR] MG18May33
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("c" & rows.Count).End(xlUp))
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        c = c + 1
        Range("D" & c) = Dn
    [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Davers]

Sweet! Thanks Dan..that did it. Thanks... Both versions worked..

Dave

 

[Davers]

And yours worked too Mick! Thanks guys!! I appreciate it!

Dave

 

[Rick Rothstein]

Well, you apparently do not need it any more, but since I developed it, and since it is a different approach than the other posted solutions, I figured I would post it for archival purposes...

Sub ThreeColumnsToOne()
  Dim X As Long, LastRow As Long
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Application.ScreenUpdating = False
  For X = LastRow To 2 Step -1
    Cells(X, "A").Resize(3) = WorksheetFunction.Transpose(Cells(X, "A").Resize(1, 3))
    Rows(X).Resize(2).Insert
  Next
  Columns("B:C").Clear
  Rows("2:3").Delete
  Range("A1").Value = "List"
  Application.ScreenUpdating = True
End Sub

 

[Davers]

I appreciate it Rick!!

Dave