Excel VBA/Macro Loop through Columns and Sort Each Column Independently by Color & then Remove Cells with Background Color

Question

I am a complete newbie when it comes to VBA. I am hoping that someone will take pity on me and help me to create the code of my dreams!

I am trying to loop through columns and sort them based on background color. The columns should always be sorted from top to bottom as: no color, green, orange, & grey. Each column differs in length. Each column does not always contain all colors. The number of columns also changes (based on the month). There is text in the cells, but the text does not matter.

The data is on "Sheet1" and I would like the data to remain the same on "Sheet1" but copy the updated sorted data to "Sheet2".

This is how Sheet 1 and 2 should look.

Once the updated sorted data has been added to "Sheet2", I would like to remove all cells that have background color. (ie The background color & text would be deleted & and only the original cells with no background w/text would remain.)

Again, I would like the "Sheet2" data to remain the same and copy the updated data onto "Sheet3".

This is how Sheet 2 and 3 should look.

The only code I have is based off of a Macro I created to sort column A by background color.

Sub Macro2()
'
' Macro2 Macro
'

'
    Range("A26:A41").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("A26:A41" _
        ), SortOn:=xlSortOnCellColor, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add(Range("A26:A41"), _
        xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(146, _
        208, 80)
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add(Range("A26:A41"), _
        xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, _
        192, 0)
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add(Range("A26:A41"), _
        xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(128, _
        128, 128)
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A26:A41")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Answer 1

Try this:

Sub Macro1()

    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim wb As Workbook, rng As Range, c As Range, colors, rngCol As Range
    
    colors = Array(RGB(128, 128, 128), RGB(146, 208, 80), RGB(255, 192, 0))
    
    Set wb = ThisWorkbook
    Set ws1 = wb.Worksheets("Sheet1")
    Set ws2 = wb.Worksheets("Sheet2")
    Set ws3 = wb.Worksheets("Sheet3")
    
    ws2.Cells.Clear 'clear previous work
    ws3.Cells.Clear
    
    Set rng = ws1.Range("A1").CurrentRegion
    AddCellColors rng.Offset(1), colors 'for testing only...
    
    Set c = ws2.Range("A1")
    rng.Copy c
    'loop over the date headers and sort each data column on color
    Do While Len(c.Value) > 0
        If Len(c.Offset(1).Value) > 0 Then 'any data below this header?
            Set rngCol = ws2.Range(c.Offset(1), ws2.Cells(Rows.Count, c.Column).End(xlUp))
            SortRangeOnColor rngCol, colors
        End If
        Set c = c.Offset(0, 1) 'next header
    Loop
    
    ws2.Range("A1").CurrentRegion.Copy ws3.Range("A1") 'copy to sheet3
    'loop and clear all colored cells
    For Each c In ws3.Range("A1").CurrentRegion.SpecialCells(xlCellTypeConstants)
        If c.Interior.ColorIndex <> xlNone Then c.Clear
    Next c
    
End Sub

'sort range `rng` on array of colors `arrColors`
Sub SortRangeOnColor(rng As Range, arrColors)
    Dim i As Long
    With rng.Worksheet.Sort
        With .SortFields
            .Clear
            For i = LBound(arrColors) To UBound(arrColors)
                .Add(rng, xlSortOnCellColor, xlDescending, , xlSortNormal). _
                                         SortOnValue.Color = arrColors(i)
            Next i
        End With
        .SetRange rng
        .header = xlNo
        .Orientation = xlTopToBottom
        .Apply
    End With
End Sub

'for testing only - add colors from array to cells in range `rng`
'  some cells are left uncolored
Sub AddCellColors(rng As Range, arrColors)
    Dim c As Range, indx, ub
    ub = UBound(arrColors)
    rng.Interior.ColorIndex = xlNone
    For Each c In rng.Cells
        If Len(c.Value) > 0 Then
            indx = Application.RandBetween(0, UBound(arrColors) + 2)
            If indx <= ub Then c.Interior.Color = arrColors(indx)
        End If
    Next c
End Sub