Sorting columns

  • Thread starter Thread starter oldjay
  • Start date Start date
O

oldjay

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
 
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).EntireRow.Delete
End Sub
 
Thanks for the reply, This code doesn't limit the rows. I want to copy rows 2
thru 31
 
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
 
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
 
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
 
Thanks That did it

oldjay said:
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
Click to expand...
 
Back
Top