I'm far from an Excel person!

I need to sort (or group) some shaded cells on a worksheet.

History: 6000+ rows, 5000 or so of them being shaded yellow.

Need to group all of the yellow shaded at the top of the page.

Only needed for a one time deal.

Any suggestions will be appreciated.

Thanks.

Is there any criteria for the rows to be shaded yellow?

Eric

No, That's the problem, there were manually shaded, I had already thought of that, but there was nothing to use to do it.

Since it was a one time only deal, I just put '1' in all of the shaded cells of a blank column and sorted by that. Problem Solved.

But since I love learning, can any offer a solution for something like this in the future?

Thanks.

Hello Anthony,¨

see if this small utility helps.

paste the Module1, Userform1 and eventually Sheet1 class code into your workbook. I know you're VB guru so I believe no further instructions needed.

You could do the following:

1) make a back-up of your sheet

2) With the manipulated sheet active, run ShowMe() sub.

3) Pick up the column and color (yellow), click Filter

4) Select the range, go to Edit=>Go To=>Special=>Visible, then Copy, paste into a new sheet.

5) go back to the original sheet, delete the filtered rows (that you have copied by now)

6) now only the rest of the rows remained, copy them below the rows copied below

I hope I am not too confusing

regards,

Martin

Hello again Anthony,

I have posted my post without noticing that you'd sorted your prob already.

However, this may come handy for the future:

(1) One could think of the following code:

Sub SortOutActiveCellColor2()
    'VERY SLOW, hit Ctrl & Break after you get bored!!!
    Dim lActCol As Long, lActColI As Long, lLastRow As Long
    Dim i As Long
    lActCol = ActiveCell.Column
    lActColI = ActiveCell.Interior.ColorIndex
    lLastRow = [a65536].End(3).Row
    i = lLastRow
    Do While i > 1
    If Cells(i, lActCol).Interior.ColorIndex = lActColI Then
        Cells(i, lActCol).EntireRow.Cut: Cells(2, lActCol).EntireRow.Insert
    Else
        i = i - 1
    End If
    Loop
End Sub

This simple code loops through all cells within the active cell's column and compares their interior color to the one of the Active Cell. If matched then the row is cut/inserted at the top, etc.
this code is veeeery slooow, as it does up to some 10000 cut/paste processes (I tested on enclosed workbook - 10000 data rows). Hit Ctrl & Break after you get bored I did always.

(2) Your approach is much better. The problem is that you should loop again and decide whether to put "1" or not, then sort. this would be much faster then the first example but the loop still remains. Unfortunately Excel offers no formula that extracts the interior color - such a formula could be entered into the inserted column in one blow, range sorted and the thing's done in a jiffy.

Good thing is that there's an ancient Excel4 formula "GET.CELL" that you can't use in a worksheet but YOU CAN use it in named formulas.

This code automates what you did manually - only it puts the real colorindex instead of "1" and all the other colors are returned as "0". i also index the original rows in order to be sure that the order stays. this may not be necessary.

here's the code (testing workbook attached)

Sub SortOutActiveCellColor()
    Dim strNamedFormula
    Dim lActCol As Long, lActColI As Long
    lActCol = ActiveCell.Column
    lActColI = ActiveCell.Interior.ColorIndex
    '
    'insert a new column with GET.CELL formula
    Columns(lActCol + 1).Insert
    strNamedFormula = "=IF(GET.CELL(38,OFFSET(R2C[-1],ROW()-2,0))=" & lActColI & "," & lActColI & ",0)"
    ActiveWorkbook.Names.Add Name:="GetColorIndex", RefersToR1C1:=strNamedFormula
    With Range(Cells(2, lActCol), Cells(65536, lActCol).End(3)).Offset(0, 1)
        .Formula = "=GetColorIndex"
        .Value = .Value
    End With
    '
    'index the rows
    Columns(1).Insert
    [A1] = "ROW"
    With Range("A2:A" & [b65536].End(3).Row)
        .Formula = "=ROW()"
        .Value = .Value
    End With
    '
    'sort color index first, then row index
    [A1].Sort Key1:=Cells(1, lActCol + 2), Order1:=xlDescending, _
                    Key2:=Range("A1"), Order2:=xlAscending, _
                    Header:=xlYes, OrderCustom:=1
    '
    'delete the dummy columns and names
    Columns(lActCol + 2).Delete
    Columns(1).Delete
    [A1].Select
    ActiveWorkbook.Names("GetColorIndex").Delete
End Sub

Best regards,

Martin

I don't think the first attachment made it.
Here it is once more.
M.

Please disregard the first code I've posted. Not only it's slow, it can also end up in infinite loop =>Ctrl+Break is a must.

Here's the corrected (but still not recommended version):

Sub SortOutActiveCellColor2()
    'VERY SLOW, hit Ctrl & Break after you get bored!!!
    Dim lActCol As Long, lActColI As Long
    Dim lActRow As Long, lLastCopy As Long
    lActCol = ActiveCell.Column
    lActColI = ActiveCell.Interior.ColorIndex
    lActRow = [a65536].End(3).Row
    lLastCopy = 1
    Application.ScreenUpdating = False
    Do
        If lLastCopy = lActRow Then Exit Do
        If Cells(lActRow, lActCol).Interior.ColorIndex = lActColI Then
            Cells(lActRow, lActCol).EntireRow.Cut: Cells(2, lActCol).EntireRow.Insert
            lLastCopy = lLastCopy + 1
        Else
            lActRow = lActRow - 1
        End If
    Loop
    Application.ScreenUpdating = False
End Sub

Sorry for that
martin

The utility worked perfectly!!!

I tested on a smaller amount of data, but have passed it on to my client who needed to do it on his own.

I'll post back the feedback/results from it.

Thanks.