Now does rows 2 to 31

Sub marine()
Dim NewRow As Long, NewColumn As Long
Dim X As Long
NewRow = 1
NewColumn = 11
For col = 1 To 10
For X = 2 To 31
If Cells(X, col) < "" Then
Cells(NewRow, NewColumn).Value = Cells(X, col).Value
NewRow = NewRow + 1
End If
Next
Next

lastrow = ActiveSheet.Cells(Rows.Count, NewColumn).End(xlUp).Row
With ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort
.SetRange Range("K1:K" & lastrow)
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

Mike

"oldjay" wrote:

Thanks for the reply, This code doesn't limit the rows. I want to copy rows 2
thru 31

"Mike H" wrote:

Hi,

try this it copies the first 10 columns to column 11 omitting blanks

Sub marine()
Dim NewRow As Long, NewColumn As Long
Dim X As Long, Col as Long
NewRow = 1
NewColumn = 11 'Change to suit
For col = 1 To 10
For X = 1 To ActiveSheet.Cells(Rows.Count, col).End(xlUp).Row
If Cells(X, col) < "" Then
Cells(NewRow, NewColumn).Value = Cells(X, col).Value
NewRow = NewRow + 1
End If
Next
Next
End Sub

Mike

"oldjay" wrote:

I have 10 columns with 30 entry cells. Some cells have a single word other
are blank.
I want to copy all words to a single colum and them alphabetize them