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

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

oops, forgot the sort bit

Sub marine()
Dim NewRow As Long, NewColumn As Long
Dim X As Long
NewRow = 1
NewColumn = 11
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

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 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

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

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

It now gives error 438 Object doesn't support this property or method at
"With ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort"

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("P1:P" & lastrow)
..Orientation = xlTopToBottom
..SortMethod = xlPinYin
..Apply
End With
End Sub


"Mike H" wrote:

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

Thanks That did it

"oldjay" wrote:

It now gives error 438 Object doesn't support this property or method at
"With ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort"

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("P1:P" & lastrow)
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub


"Mike H" wrote:

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

Use this and then just sort col A

Sub copycolstocola()
For i = 2 To 10
lr = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(1, i).Resize(30).Copy Cells(lr, 1)
Next i
Columns(1).SpecialCells(xlCellTypeBlanks).EntireRo w.Delete
End Sub

--
Don Guillett
Microsoft MVP Excel
SalesAid Software

"oldjay" wrote in message
...
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

Macro by Bernie Dietrick.

You can sort after the macro has finished.

Record a macro while you sort then combine at end of Bernie's macro.

Sub OneColumnV2()
''''''''''''''''''''''''''''''''''''''''''
'Macro to copy columns of variable length'
'into 1 continous column in a new sheet '
'Modified 17 FEb 2006 by Bernie Dietrick
''''''''''''''''''''''''''''''''''''''''''
Dim iLastcol As Long
Dim iLastRow As Long
Dim jLastrow As Long
Dim ColNdx As Long
Dim WS As Worksheet
Dim myRng As Range
Dim ExcludeBlanks As Boolean
Dim mycell As Range

ExcludeBlanks = (MsgBox("Exclude Blanks", vbYesNo) = vbYes)
Set WS = ActiveSheet
iLastcol = WS.Cells(1, WS.Columns.Count).End(xlToLeft).Column
On Error Resume Next

Application.DisplayAlerts = False
Worksheets("Alldata").Delete
Application.DisplayAlerts = True

Sheets.Add.Name = "Alldata"

For ColNdx = 1 To iLastcol

iLastRow = WS.Cells(WS.Rows.Count, ColNdx).End(xlUp).Row

Set myRng = WS.Range(WS.Cells(1, ColNdx), _
WS.Cells(iLastRow, ColNdx))

If ExcludeBlanks Then
For Each mycell In myRng
If mycell.Value < "" Then
jLastrow = Sheets("Alldata").Cells(Rows.Count, 1) _
.End(xlUp).Row
mycell.Copy
Sheets("Alldata").Cells(jLastrow + 1, 1) _
.PasteSpecial xlPasteValues
End If
Next mycell
Else
myRng.Copy
jLastrow = Sheets("Alldata").Cells(Rows.Count, 1) _
.End(xlUp).Row
mycell.Copy
Sheets("Alldata").Cells(jLastrow + 1, 1) _
.PasteSpecial xlPasteValues
End If
Next

Sheets("Alldata").Rows("1:1").entirerow.Delete

WS.Activate
End Sub


Gord Dibben MS Excel MVP

On Tue, 1 Dec 2009 12:36:08 -0800, 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