Excel VBA: Outputting cell row and column titles if cell is colored

Question

I'm fairly new to VBA and I've been struggling over this problem for a couple weeks.

Every time a name has passed a training, the corresponding name/training title cell is filled with the date, and the background is filled in yellow RGB(255,255,0). When IN training they are filled with a yellow background and no date. (There are also some that are red or grey for out of date, but I think I have already worked those out.)

The end goal is to have a separate output sheet within the same file. This sheet will only contain the necessary Training Titles at the top, and all of the names under it if they are the blank yellow cells (No date + yellow). Eventually I would like to be able to email this list to certain people, but I think there are enough resources to figure that out myself.

Currently, I have code to find the max/min of the column/rows, and code that deletes all cells containing dates. My plan was to have it scan the remaining cells for any that were yellow, then paste the training titles/names on a new sheet, but I cannot figure out how to that in VBA.

I'm sure there has to be an easier way to do this as it is several hundred columns wide and rows long.

Thanks for any input!

EDIT: This is the code I am currently using. This scans the range of name vs training and clears the cell data if it is any other color than yellow, or if it is yellow with a date.

I attached an image to help explain more clearly. The important cells are the ones that are yellow with no date. From those cells I need to paste the Training Title in Row 1, and the Name of the person in Column A on a new sheet in the way you can see in the picture.

Sub ClearCellMacro()

Dim myLastCell As Range
Dim cell As Range

Application.ScreenUpdating = False

'Find last cell
Set myLastCell = Range("C4").SpecialCells(xlLastCell)

'Make sure last cell is outside of first row and column (or else exit)
If myLastCell.Row = 1 Or myLastCell.Column = 1 Then Exit Sub

'Loop through entire range removing cell contents if value is not numeric
For Each cell In Range("C4:" & myLastCell.Address)
    If Not IsNumeric(cell) Then cell.Clear
Next cell

For Each cell In Range("C4:" & myLastCell.Address)
    If cell.Interior.Color <> RGB(255, 255, 0) Then cell.Clear
Next cell

Application.ScreenUpdating = True

MsgBox "Non-Yellow + Blank Cells Removed."

End Sub

That doesn't address what I'm looking for. I can delete cells based on color and content. I need it to instead analyze what cells have the property of the yellow color, the 255,255,0 I mentioned above, then copy the row and column titles based on its location. — cbuerm, Sep 19 '18 at 19:57
You're struggling with how to copy a cell from one sheet to the next then? A) please [edit] your post to make that much more clear. B) Post the code you've tried, someone will point you in the right direction. — FreeMan, Sep 19 '18 at 19:59
What have you tried - post any code? If you are basically searching for yellow cells use the Find method and set the SearchFormat parameter. — SJR, Sep 19 '18 at 20:00
Added the code which clears cells with any other color than yellow, or ones that are yellow with a date. The ones I need to keep in that range are the yellow ones with no dates. From there I need to get the corresponding row and column titles for the Training and Name. Hopefully the image helps. — cbuerm, Sep 19 '18 at 20:18

urdearboy · Accepted Answer · 2018-09-19T21:47:02.367

This will not clear the non-numeric cells. I am assuming that is already done.

Any cell that is blank and highlighted yellow will be moved to a table on Sheet2 with corresponding name.

You need to update the 3rd and 4th line of code to reflect your actual sheet names (make sure to leave the quotes of course). Sheet1 reflects your "starting sheet" in photo and Sheet2 reflects your desired output.

This is dynamic by rows and columns. Last row (lRow) is determined by Column A and last column (lCol) is determined by Row 1. Photo of the starting point and output produced by the below macro.

Option Explicit

Sub TestMe()

Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")

Dim lCol As Long: lCol = ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
Dim lRow As Long: lRow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row

Dim myRange As Range, myCell As Range, myUnion As Range
Dim i as Long

For i = 3 To lCol 'Open column loop
Set myRange = ws1.Range(ws1.Cells(4, i), ws1.Cells(lRow, i))
    For Each myCell In myRange 'Open row loop
        If myCell = "" And myCell.Interior.Color = 65535 Then
            If myUnion Is Nothing Then
                Set myUnion = myCell.Offset(0, -i + 1)
            Else
                Set myUnion = Union(myUnion, myCell.Offset(0, -i + 1))
            End If
        End If
    Next myCell 'Next Row

    If Not myUnion Is Nothing Then 'This will need some updating to dynamically paste in first available column
        ws2.Cells(1, i - 2).Value = ws1.Cells(1, i).Value
        myUnion.Copy
        ws2.Cells(2, i - 2).PasteSpecial xlPasteValues
        Set myUnion = Nothing
    End If

Next i 'Next Column

End Sub

This wasn't an easy one. Some feed back would be appreciated — urdearboy, Sep 19 '18 at 23:57
I had not attempted anything with Union and this is working great. I will be able to test it with the full sheet tomorrow. I tried it with a new excel file and filled in the appropriate cells and it works great. The only issue I see is when a column contains no blank+yellow cells, it outputs an empty column on Sheet2. I'm unsure of the VBA syntax but I think I should be able to figure out another loop to scan through sheet 2 for empty cells in row 1 and delete the column if so. I can't express my gratitude enough, this is amazing, thank you! — cbuerm, Sep 20 '18 at 14:58
I left a comment on where that needs to happen (It's at the bottom next to `If Not myUnion is Nothing Then` — urdearboy, Sep 20 '18 at 15:02

Excel VBA: Outputting cell row and column titles if cell is colored

1 Answers1