Sort by rows left to right based on cell font color

[naturally_data]

Hi,

Hoping for some help please. I need to be able to sort by row based on the font color of the cell content so that it is sorted left to right by color.
As in the example below, I'd like to sort the cell with red font to the left. I'd like each row to be sorted separately. I've used reecorded macro excel but that has not proven useful.
Regardless of where the data is located I want to be able to select the range I would like to be sorted. The most I've gotten is the VBA shown below. It is not working for me.
Thank you very much in advance for your kind help.

Sub sort_rows_left_to_right_by_color()
Dim wks As Worksheet
Dim rng As Range
Dim i As Long

Set wks = ActiveSheet
Set rng = Application.InputBox("Select range with the mouse", Type:=8)
If Not rng Is Nothing Then
With rng
For i = 1 To .Rows.Count
With .Rows(i)

With wks.Sort
With .SortFields
.Clear
.Add(Key:=.Rows(i).Range("A1")),xlSortOnFontColor, xlAscending, xlSortNormal).SortOnValue.Color = RGB(255, 0, 0)

End With
.Sort.Header = xlYes
.Sort.Orientation = xlLeftToRight
.Sort.Apply
End With
Next
End With
End Sub

#1 Column A	#2 Column B	#3 Column C	#4 Column D	#5 Column E	#6 Column F
1	2	3	4	5	6
10	11	19	67	99	76
00	00	23	32	55	78

 

[naturally_data]

Scratch that. Had to be user error on part.
I think I have to adjust my data range so that it's beyond E2:J6.
The code is sufficient as-is. No further work needed.
I will try to learn from this line by line to try to progress in my vba journey.
You are a HERO!
Thank you.

 

[HighAndWilder]

I can build in a means by which you can select the data range each time that it is run.

It will then handle any number of rows and columns.

 

[naturally_data]

That would be awesome. If you don't mind.
Stepping to get something at the store. Be back online later. Thanks!

 

[vcoolio]

Hello ND,

I've just come across your thread so, out of curiosity, I noticed that the code you supplied in your opening post was very close to the mark.

Adjusting it a little as follows may help (but I've not tested it):-

Sub sort_rows_left_to_right_by_color()

Dim wks As Worksheet, rng As Range

        Set wks = ActiveSheet
        Set rng = Application.InputBox("Select range with the mouse", Type:=8)
        If Not rng Is Nothing Then

        wks.Sort.SortFields.Clear
        wks.Sort.SortFields.Add(rng, xlSortOnFontColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, 0, 0)

        With wks.Sort
                .SetRange rng
                .Header = xlYes
                .Orientation = xlLeftToRight
                .Apply
        End With
End If

End Sub

The range InputBox will only allow you to select a row at a time but it should work for you.

I hope that this helps. Good luck!

Cheerio,
vcoolio.

 

[HighAndWilder]

This allows you to select a range, checks it validity and then refreshes the data as it proceeds.

Comment out the 'Call subReset(rngData)' line if you do not wat to create a set of test data.

Public Sub subRunCode()
Dim rngData As Range

    ActiveWorkbook.Save
    
    Application.ScreenUpdating = True

    Set rngData = fncGetDataRange()
    If rngData Is Nothing Then
        Exit Sub
    End If
        
    Call subReset(rngData)
    
    Call subReorderColourCells(rngData)
    
    MsgBox "Finished"
    
End Sub

Public Sub subReset(rngData As Range)
Dim lngColor As Long
Dim rngCell As Range

            Range("E1").Select
            
            Application.ScreenUpdating = True
                            
            With Range("E2:M" & ActiveSheet.UsedRange.Rows.Count)
                .Clear
                .Font.Size = 14
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End With
            
            Range("L" & rngData.Row & ":M" & rngData.Rows.Count + 1).Borders.LineStyle = xlContinuous
            
            rngData.Borders.LineStyle = xlContinuous
   
            ' Set the colours.
            For Each rngCell In rngData.Cells
                rngCell.Value = Int(1 + Rnd * (30 - 1 + 1))
                lngColor = Int(1 + Rnd * (2 - 1 + 1))
                rngCell.Font.Color = IIf(lngColor = 1, vbRed, 0)
            Next rngCell
            
End Sub

Private Function fncGetDataRange() As Range
Dim rngData As Range
Dim strMsg As String
Dim rngCell As Range
Dim blnFailed As Boolean
Dim rngArea As Range

        On Error Resume Next
        Set rngData = Application.InputBox(Prompt:="Select range to sort by cell color.", Title:="Range Selection", Type:=8)
        On Error GoTo 0
        
        On Error GoTo Err_Handler
        
        ' Test to ensure User did not cancel
        If rngData Is Nothing Then
            
            strMsg = "You either cancelled or selected a range that was not valid"
            
            blnFailed = True
        
        Else
            
            ' Have multiple ranges been selected.
            If Not blnFailed Then

                If rngData.Areas.Count > 1 Then
                    MsgBox rngData.Address
                    blnFailed = True
                    strMsg = "You have selected more than one range."
                    Set fncGetDataRange = Nothing
                End If
            
            End If
            
            ' Check to see if a valid range has been selected.
            If Not blnFailed Then
                For Each rngCell In rngData.Cells
                    If Not IsNumeric(rngCell.Value) Then
                        blnFailed = True
                        strMsg = "You have selected a range that was not valid"
                        Set rngData = Nothing
                        ' Set fncGetDataRange = Nothing
                        Exit For
                    End If
                Next rngCell
            End If
        
        End If

Exit_Handler:
        
        If strMsg <> "" Then
            
            MsgBox strMsg, vbCritical, "Warning"
        
            Exit Function
        
        Else
            
            rngData.Interior.Color = RGB(179, 236, 255)
            
            ActiveWindow.ScrollRow = WorksheetFunction.Max(rngData.Row - 2, 1)
                    
            If MsgBox("Proceed to sort the data by font color?", vbYesNo, "Range confirmation.") = vbYes Then
                rngData.Interior.Color = RGB(255, 255, 255)
                Set fncGetDataRange = rngData
            End If
            
            rngData.Interior.Color = RGB(255, 255, 255)
            
        End If
        
        Exit Function
        
Err_Handler:

    strMsg = "A error has occured preventing completion of this procedure"
    
    Set rngData = Nothing
    
    MsgBox Err.Number & "   " & Err.Description

    Resume Exit_Handler

End Function

Public Sub subReorderColourCells(rngData As Range)
' Dim rngData As Range
Dim i As Integer
Dim intRow As Integer
Dim rngCell As Range
Dim lngColor As Long
Dim rngRow As Range
Dim intValue As Integer
Dim rngCopy As Range
Dim rngPaste As Range
Dim intCurrent As Integer
Dim strCheck As String
Dim rngRefreshCell As Range

        On Error GoTo Err_Handler
        
        Application.EnableEvents = False
        
        Set rngData = rngData.Offset(0, 1).Resize(rngData.Rows.Count, rngData.Columns.Count - 1)
        
        For Each rngRow In rngData.Rows
        
            ActiveWindow.ScrollRow = WorksheetFunction.Max(rngRow.Row - 1, 1)
        
            intRow = rngRow.Row
            
            Range("K" & intRow) = "<<<<<<"
                        
            Do While True
                
                strCheck = ""
                For Each rngCell In rngRow.Offset(0, -1).Resize(1, 6).Cells
                    strCheck = strCheck & IIf(rngCell.Font.Color = 0, "B", "R")
                Next rngCell
                
                For i = 5 To 1 Step -1
                    
                    Range("L" & rngRow.Row & ":M" & rngRow.Row) = Array(6 - Len(Replace(strCheck, "R", "")), 6 - Len(Replace(strCheck, "B", "")))
                    
                    ' Check to see if there are any unfullfilled orders before fulfilled ones.
                    If InStr(1, strCheck, "BR", vbTextCompare) = 0 Then
                        Exit Do
                    End If
                    
                    Set rngCell = rngRow.Cells(1, i)
                  
                    If rngCell.Font.Color = vbRed Then
                        
                        intValue = rngCell.Value
                        Set rngCopy = Range("E" & rngCell.Row).Resize(1, IIf(i = 1, 1, i))
                        Set rngPaste = rngCopy.Offset(0, 1)
                        
                        Application.ScreenUpdating = False
                        rngCopy.Copy
                        rngPaste.PasteSpecial xlPasteFormats
                        Application.CutCopyMode = False
                        Range("E1").Select
                        rngPaste = rngCopy.Value
                        Application.ScreenUpdating = True
                            
                        Range("E" & intRow).Value = intValue
                        Range("E" & intRow).Font.Color = vbRed
                        
                        For Each rngRefreshCell In rngRow.Offset(0, -1).Resize(1, 6).Cells
                            rngRefreshCell.Font.Color = rngRefreshCell.Font.Color
                        Next rngRefreshCell
                        
                        Application.ScreenUpdating = True
                        
                    End If ' If vbRed
                
                Next i  ' Next Cell in row - goes backwards.
                
            Loop
        
            Range("K" & rngRow.Row) = ""
        
        Next rngRow
         
Exit_Handler:
    
        Application.EnableEvents = True
         
        Application.ScreenUpdating = True
        
        ActiveWindow.ScrollRow = rngData.Row
        
        ActiveWindow.ScrollColumn = 1
        
        Exit Sub

Err_Handler:

    MsgBox Err.Number & "   " & Err.Description

    Resume Exit_Handler

End Sub

 

[naturally_data]

Really can't thank you enough H&W. This will really help me out tons. May good Karma come your way. It works wonders.
Have a fantastic day!!

 

[naturally_data]

Hi vcoolio,

Thanks for also addressing my vba problem. While the modification you've made did not work due to this error:
Run-time error ‘1004’: The sort reference is not valid. Make sure that its’ within the data you want to sort, and the first Sort By box isn’t the same or blank.
I don't want you to spend any more time on this now that I've already got a working version from H&W.
Thank you very much for your great efforts.

 

[HighAndWilder]

Pleased to be able to help naturally_data.