Color Sort
 

Hello,
the following code should sort by color. However, if the spreadsheet is
large the macro runs a very long time. Will someone write some code that's
more efficient for large spreadsheets, say over 10K lines?

Thank you.
JHL

Sub ColorSorter()
y = ActiveCell.Column - 1
J = Range("IV1").End(xlToLeft).Column
BotRow = Range("A65536").Offset(0, y).End(xlUp).Row - 1

Range("A1").Offset(0, J) = "Sort"
For i = 1 To BotRow
Range("A1").Offset(i, J) = Range("A1").Offset(i,
y).Interior.ColorIndex
Next
Cells.Sort Key1:=Range("A1").Offset(0, J), Order1:=xlAscending,
Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Columns(J + 1).Delete
End Sub

Color Sort
 

THANK YOU and also for the comments about the speed.

Perhaps I should think of a better index for sorting, then just color code
the result.

"Jim Thomlinson" wrote:

This is going to take a long time to run no matter what you do... here it is
with a couple of tweaks but it is going to be a slow process

Sub ColorSorter()
dim y as long
dim J as long
dim BotRow as long

Application.Screenupdating = false

y = ActiveCell.Column - 1
J = Range("IV1").End(xlToLeft).Column
BotRow = Cells(rows.count, "A").Offset(0, y).End(xlUp).Row - 1

Range("A1").Offset(0, J) = "Sort"
For i = 1 To BotRow
Range("A1").Offset(i, J) = Range("A1").Offset(i,
y).Interior.ColorIndex
Next i
Cells.Sort Key1:=Range("A1").Offset(0, J), Order1:=xlAscending,
Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Columns(J + 1).Delete
Application.Screenupdating = true

End Sub
--
HTH...

Jim Thomlinson


"JHL" wrote:

Hello,
the following code should sort by color. However, if the spreadsheet is
large the macro runs a very long time. Will someone write some code that's
more efficient for large spreadsheets, say over 10K lines?

Thank you.
JHL

Sub ColorSorter()
y = ActiveCell.Column - 1
J = Range("IV1").End(xlToLeft).Column
BotRow = Range("A65536").Offset(0, y).End(xlUp).Row - 1

Range("A1").Offset(0, J) = "Sort"
For i = 1 To BotRow
Range("A1").Offset(i, J) = Range("A1").Offset(i,
y).Interior.ColorIndex
Next
Cells.Sort Key1:=Range("A1").Offset(0, J), Order1:=xlAscending,
Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Columns(J + 1).Delete
End Sub

Color Sort
 

If you incorporate the following modification your colour sort should be
pretty fast, even with 10k rows -

Change -
For i = 1 To BotRow
Range("A1").Offset(i, J) = Range("A1").Offset(i,
y).Interior.ColorIndex
Next

to -

Dim rng As Range, cel As Range
Set rng = Range("A1").Offset(, y).Resize(BotRow, 1)

ReDim arrClrIdx(1 To BotRow, 1 To 1) As Long
For Each cel In rng
i = i + 1
arrClrIdx(i, 1) = cel.Interior.ColorIndex
Next
Range("A1").Offset(, j).Resize(BotRow, 1) = arrClrIdx

I've tried to adapt with your variables and column to sort method, eg your
BotRow doesn't seem right -

BotRow = Range("A65536").Offset(0, y).End(xlUp).Row - 1
to
BotRow = Range("A65536").Offset(0, y).End(xlUp).Row

Best double check but hope you get the basic idea.

Also declare your other variables
Dim y As Long, j As Long, i As Long, BotRow As Long

Regards,
Peter T


"JHL" wrote in message
...
Hello,
the following code should sort by color. However, if the spreadsheet is
large the macro runs a very long time. Will someone write some code
that's
more efficient for large spreadsheets, say over 10K lines?

Thank you.
JHL

Sub ColorSorter()
y = ActiveCell.Column - 1
J = Range("IV1").End(xlToLeft).Column
BotRow = Range("A65536").Offset(0, y).End(xlUp).Row - 1

Range("A1").Offset(0, J) = "Sort"
For i = 1 To BotRow
Range("A1").Offset(i, J) = Range("A1").Offset(i,
y).Interior.ColorIndex
Next
Cells.Sort Key1:=Range("A1").Offset(0, J), Order1:=xlAscending,
Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Columns(J + 1).Delete
End Sub

Color Sort
 

Peter T
WOW is all I can say. These mods made it lightin' FAST!!!

Thanks

"Peter T" wrote:

If you incorporate the following modification your colour sort should be
pretty fast, even with 10k rows -

Change -
For i = 1 To BotRow
Range("A1").Offset(i, J) = Range("A1").Offset(i,
y).Interior.ColorIndex
Next

to -

Dim rng As Range, cel As Range
Set rng = Range("A1").Offset(, y).Resize(BotRow, 1)

ReDim arrClrIdx(1 To BotRow, 1 To 1) As Long
For Each cel In rng
i = i + 1
arrClrIdx(i, 1) = cel.Interior.ColorIndex
Next
Range("A1").Offset(, j).Resize(BotRow, 1) = arrClrIdx

I've tried to adapt with your variables and column to sort method, eg your
BotRow doesn't seem right -

BotRow = Range("A65536").Offset(0, y).End(xlUp).Row - 1
to
BotRow = Range("A65536").Offset(0, y).End(xlUp).Row

Best double check but hope you get the basic idea.

Also declare your other variables
Dim y As Long, j As Long, i As Long, BotRow As Long

Regards,
Peter T


"JHL" wrote in message
...
Hello,
the following code should sort by color. However, if the spreadsheet is
large the macro runs a very long time. Will someone write some code
that's
more efficient for large spreadsheets, say over 10K lines?

Thank you.
JHL

Sub ColorSorter()
y = ActiveCell.Column - 1
J = Range("IV1").End(xlToLeft).Column
BotRow = Range("A65536").Offset(0, y).End(xlUp).Row - 1

Range("A1").Offset(0, J) = "Sort"
For i = 1 To BotRow
Range("A1").Offset(i, J) = Range("A1").Offset(i,
y).Interior.ColorIndex
Next
Cells.Sort Key1:=Range("A1").Offset(0, J), Order1:=xlAscending,
Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Columns(J + 1).Delete
End Sub