excel VBA if background color then

Ferlucia

New Member
Joined
Jul 3, 2014
Messages
43
Hello everyone,

I'm trying to create a VBA code that works with background color and does:

IF all filled cells in a row (starting from column F) have a green background then the correspondig cell in D gets a green backgroud.
IF 1 or more (but not all) filled cells in a row (starting from column F) have a green background then the corresponding cell in D gets a yellow background.
IF none of the filled cells in a row (starting from column F) have a green background then the corresponding cell in D stays white.

The amount of filled cells per row is VARIABLE
This code should only start from row 4 and down

Hope you can help
 

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.
Two questions...

1) "IF all filled cells in a row (starting from column F)"... your wording is odd and needs clarification. Could there be uncolored cells between colored cells on a single row and, if so, are they to be ignored? In other words, is the criteria to only look at cells that are colored when determining if the colors are all the same or would any blank cells count as not being the same color?

2) How do the cells get their colors... manually (which includes by VBA code) or by means of Conditional Formatting?
 
Upvote 0
Thanks for the replay

1) there are either uncolored or green cells. So it imported to look at all filled cells in a row, and if any are uncolored D becomes yellow an if they are all uncolored D remanes uncolored as well

2) the cells get their color manually
 
Upvote 0
Assuming by "filled" you mean cells that have data in them does this work for you? Note that I am using the green color associated with vbGreen (65280). You must adjust the code to match the green fill you are using.
Code:
Sub Ferlucia()
Dim lR As Long, lC As Long, rw As Range, c As Range, Ctf As Long, Ct As Long
lR = ActiveSheet.UsedRange.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Application.ScreenUpdating = False
For Each rw In Rows("4:" & lR)
    lC = rw.Find("*", , , , xlByColumns, xlPrevious).Column
    Ctf = Application.CountA(Range(Cells(rw.Row, "F"), Cells(rw.Row, lC)))
    For Each c In Range(Cells(rw.Row, "F"), Cells(rw.Row, lC))
        If Not IsEmpty(c) And c.Interior.Color = vbGreen Then
            Ct = Ct + 1
            If Ct = Ctf Then
                Cells(rw.Row, "D").Interior.Color = vbGreen
                Ct = 0
                GoTo Nx
            End If
        End If
    Next c
    If Ct > 0 Then
        Cells(rw.Row, "D").Interior.Color = vbYellow
    Else
        Cells(rw.Row, "D").Interior.Color = xlNone
    End If
Nx:
    Ct = 0
Next rw
Application.ScreenUpdating = True
End Sub
 
Upvote 0
I entered the colors, but it doesn't do anyhing.

I tried testing it, I tried closing and opening the document again but that doesn't work either.

Do I have to activate it in some way?
 
Upvote 0
I entered the colors, but it doesn't do anyhing.

I tried testing it, I tried closing and opening the document again but that doesn't work either.

Do I have to activate it in some way?
How did you install the code? Is your green vbGreen or some other shade (vbGreen is R=0, G=255, B=0)?
 
Upvote 0
I just added it in my VBA screen sheet 1.
Bellow another code.

My green is: R=146 G=208 B=80
My yellow is: R=255 G=192 B=0
 
Upvote 0
See if this macro works for you...
Code:
Sub CheckGreenColors()
  Dim R As Long
  For R = 4 To Range("F1", Cells(1, Columns.Count)).EntireColumn.Find("*", , xlValues, , xlRows, xlPrevious).Row
    Select Case Range(Cells(R, "F"), Cells(R, Columns.Count).End(xlToLeft)).SpecialCells(xlConstants).Interior.Color
      Case 0: Cells(R, "D").Interior.Color = RGB(255, 192, 0)
      Case RGB(146, 208, 80): Cells(R, "D").Interior.Color = RGB(146, 208, 80)
      Case Else: Cells(R, "D").Interior.Color = xlNone
    End Select
  Next
End Sub
 
Upvote 0
I just added it in my VBA screen sheet 1.
Bellow another code.

My green is: R=146 G=208 B=80
My yellow is: R=255 G=192 B=0
That's not sheet code. Install it as a regular module like this.
To install the code:
1. With your workbook active press Alt and F11 keys. This will open the VBE window.
2. In the project tree on the left of the VBE window, find your project and click on it.
3. On the VBE menu: Insert>Module
4. Copy the code from your browser window and paste it into the white space in the VBE window.
5. Close the VBE window and Save the workbook. If you are using Excel 2007 or a later version do a SaveAs and save it as a macro-enabled workbook (.xlsm file extension).
6. Press Alt+F8 keys to run the code
7. Make sure you have enabled macros whenever you open the file or the code will not run.
Here's revised code to match your color choices:
Code:
Sub Ferlucia()
Dim lR As Long, lC As Long, rw As Range, c As Range, Ctf As Long, Ct As Long
lR = ActiveSheet.UsedRange.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Application.ScreenUpdating = False
For Each rw In Rows("4:" & lR)
    lC = rw.Find("*", , , , xlByColumns, xlPrevious).Column
    Ctf = Application.CountA(Range(Cells(rw.Row, "F"), Cells(rw.Row, lC)))
    For Each c In Range(Cells(rw.Row, "F"), Cells(rw.Row, lC))
        If Not IsEmpty(c) And c.Interior.Color = RGB(146, 208, 80) Then
            Ct = Ct + 1
            If Ct = Ctf Then
                Cells(rw.Row, "D").Interior.Color = RGB(146, 208, 80)
                Ct = 0
                GoTo Nx
            End If
        End If
    Next c
    If Ct > 0 Then
        Cells(rw.Row, "D").Interior.Color = RGB(255, 192, 0)
    Else
        Cells(rw.Row, "D").Interior.Color = xlNone
    End If
Nx:
    Ct = 0
Next rw
Application.ScreenUpdating = True
End Sub
 
Upvote 0
It still doesn't work...

Maybe I'm doing something wrong?

I tried connecting it to a button, but for some reason I can't add any buttons...
 
Upvote 0

Forum statistics

Threads
1,213,538
Messages
6,114,218
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top