Setting Ranges to Format in VBA 3

[Randy1234]

Hi Everyone,
I have a major issue that I hope can be solved since I have spent about three days trying to figure this one out.

I have text in range1 ("A18:A300") but not in every cell. There are also numerical values in range2 ("G18:BB300") but not in every cell. As the values change in range1, I need to change the interior color of the cells in range2 that contain values. Also if I add a value to range2, then I need the cell to change to the appropriate color for the related value in range1. I wrote a code to do it one row at a time, but there has to be a better way. Any help would be greatly appreciated.

Randy

Here is the code I wrote for just one row:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Range1 As Range
Dim Range2 As Range
Dim Cell As Variant

Set Code = Range("A18:A18")
Set Track = Range("G18:BB18")


[tt]If Not Intersect(Target, Range1) Is Nothing Or _
Not Intersect(Target, Range2) Is Nothing Then
For Each Cell In Range2
If Range1 = "s" And Cell > 0 Then
Cell.Interior.ColorIndex = 34

ElseIf Range1 = "o" And Cell > 0 Then
Cell.Interior.ColorIndex = 50

ElseIf Range1 = "e" And Cell > 0 Then
Cell.Interior.ColorIndex = 40

ElseIf Range1 = "f" And Cell > 0 Then
Cell.Interior.ColorIndex = 41

ElseIf Range1 = "ee" And Cell > 0 Then
Cell.Interior.ColorIndex = 7

ElseIf Range1 = "p" And Cell > 0 Then
Cell.Interior.ColorIndex = 6

ElseIf Range1 = "" Or Cell = "" Then
Cell.Interior.ColorIndex = xlblank

End If
Next Cell
End If
End Sub[/tt]

 

[SkipVought]

Hi,

1) seems like Code should be Range1 and Track should be Range2. You never assign Range1 or Range2

2) Cell is a Range -- So you loop thru the cells in Range2.

Here's another problem

        If Range1 = "s" And Cell > 0 Then
        Cell.Interior.ColorIndex = 34

Range1 is just that A RANGE. So how can a RANGE be equal to a string value???

Here's probably what you want to do...

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Code As Range
Dim Track As Range
Dim Cell As Range, i As Integer

Set Code = Range("A18:A18")
Set Track = Range("G18:BB18")


If Not Intersect(Target, Code) Is Nothing Or _
Not Intersect(Target, Track) Is Nothing Then
    i = 1
    For Each Cell In Track
        If Code(i).Value = "s" And Cell > 0 Then
        Cell.Interior.ColorIndex = 34
        
        ElseIf Code(i).Value = "o" And Cell > 0 Then
        Cell.Interior.ColorIndex = 50

        ElseIf Code(i).Value = "e" And Cell > 0 Then
        Cell.Interior.ColorIndex = 40

        ElseIf Code(i).Value = "f" And Cell > 0 Then
        Cell.Interior.ColorIndex = 41

        ElseIf Code(i).Value = "ee" And Cell > 0 Then
        Cell.Interior.ColorIndex = 7

        ElseIf Code(i).Value = "p" And Cell > 0 Then
        Cell.Interior.ColorIndex = 6
        
        ElseIf Code(i).Value = "" Or Cell = "" Then
        Cell.Interior.ColorIndex = xlblank
            
        End If
        i = i + 1
    Next Cell
End If
End Sub

Skip,
[sub]
[red]A palindrome gone wrong?[/red]
A man, a plan, a ROOT canal...
PULLEMALL![/sub]

 

[Randy1234]

Thanks Skip...that works fine for just row 18, but I am looking to run this through the entire worksheet so whenever I change the value in cloumn A the cells in the same row will change to the appropriate color if they contain values.

Example:
If I type s in A18 then the cells in G18:BB18 will turn green if they have values, and when I type o in A20 then the cells in G20:BB20 will turn orange if they have values.

I guess I could copy the above code and paste it 300 times changing the row numbers, but I am trying to avoid that.

Thanks,
Randy

 

[SkipVought]

Set Code = Range("A18:A300")
Set Track = Range("G18:BB300")

Skip,
[sub]
[red]A palindrome gone wrong?[/red]
A man, a plan, a ROOT canal...
PULLEMALL![/sub]

 

[Randy1234]

That didn't work...it colored some cells and blanked out ohers. It also took a while to run through the loop. I have no idea where to turn now.

Thanks for the help

 

[SkipVought]

I have looked more closely at your logic. I have the following questions...

What should happen if a change is made in the Code range?

What should happen if a change is made in the Track range?

What values should there be in each range?

Please explain each scenerio.

Skip,
[sub]
[red]A palindrome gone wrong?[/red]
A man, a plan, a ROOT canal...
PULLEMALL![/sub]

 

[Randy1234]

The code range is in column A. The values for the code range will be S, O, E, F, EE and P. Colors are assigned to each of these codes.

The track range falls from Column G through column BB(one column per month for 4 years). The values for the track range are numeric.

When I enter/change a value in the code range, only the cells in that same row and that contain values will change to the color represented by the code. If there is no code for a row, then all the cells in that row regardless of value have no fill color.

When I enter a value in the track range, then it changes to the appropriate color based on the code for that row. If I delete a value in the track range, the color returns to blank.

Each row within the code range may have a different color.

If A18 is "O", then only the cells that have values in G18:BB18 (this may only be 6 of the cells) turn green. If I add a value to a cell in G18:BB18, then it will turn green too. If I change A18 from "O" to "S" then the the green cells turn lt blue.

If A20 is P then the cells in G20:BB20 with values will turn yellow.

Each row is independent from eachother. The colors of the cells in the track range depend on the specific code for that row found in column A (the code range).

The code I wrote was for one just one row because I couldn't figure out to put it together for all 300 rows. I hope this helps...and thank you so much for your time.

Randy

 

[SkipVought]

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Code As Range
Dim Track As Range
Dim Cell As Range

Set Code = Range("A18:A300")
Set Track = Range("G18:BB300")

If Not Intersect(Target, Code) Is Nothing Or _
Not Intersect(Target, Track) Is Nothing Then
    For Each Cell In Track
        With Cell
            If Cells(.Row, "A").Value = "s" And .Value > 0 Then
            Cell.Interior.ColorIndex = 34
            
            ElseIf Cells(.Row, "A").Value = "o" And .Value > 0 Then
            Cell.Interior.ColorIndex = 50
    
            ElseIf Cells(.Row, "A").Value = "e" And .Value > 0 Then
            Cell.Interior.ColorIndex = 40
    
            ElseIf Cells(.Row, "A").Value = "f" And .Value > 0 Then
            Cell.Interior.ColorIndex = 41
    
            ElseIf Cells(.Row, "A").Value = "ee" And .Value > 0 Then
            Cell.Interior.ColorIndex = 7
    
            ElseIf Cells(.Row, "A").Value = "p" And .Value > 0 Then
            Cell.Interior.ColorIndex = 6
            
            ElseIf Cells(.Row, "A").Value = "" Or .Value = "" Then
            Cell.Interior.ColorIndex = xlblank
                
            End If
        End With
    Next Cell
End If
End Sub

Skip,
[sub]
[red]A palindrome gone wrong?[/red]
A man, a plan, a ROOT canal...
PULLEMALL![/sub]

 

[SkipVought]

this code will be a bit more efficient, since the former loops thru each cell in Track. This code only loops thru one row

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Code As Range
Dim Track As Range
Dim Cell As Range, rng As Range

Set Code = Range("A1:A30")
Set Track = Range("G1:BB30")

If Not Intersect(Target, Code) Is Nothing Or _
Not Intersect(Target, Track) Is Nothing Then
    Set rng = Intersect(Track, Target.EntireRow)
    For Each Cell In rng
        With Cell
            If Cells(.Row, "A").Value = "s" And .Value > 0 Then
            Cell.Interior.ColorIndex = 34
            
            ElseIf Cells(.Row, "A").Value = "o" And .Value > 0 Then
            Cell.Interior.ColorIndex = 50
    
            ElseIf Cells(.Row, "A").Value = "e" And .Value > 0 Then
            Cell.Interior.ColorIndex = 40
    
            ElseIf Cells(.Row, "A").Value = "f" And .Value > 0 Then
            Cell.Interior.ColorIndex = 41
    
            ElseIf Cells(.Row, "A").Value = "ee" And .Value > 0 Then
            Cell.Interior.ColorIndex = 7
    
            ElseIf Cells(.Row, "A").Value = "p" And .Value > 0 Then
            Cell.Interior.ColorIndex = 6
            
            ElseIf Cells(.Row, "A").Value = "" Or .Value = "" Then
            Cell.Interior.ColorIndex = xlblank
                
            End If
        End With
    Next Cell
End If
End Sub

Skip,
[sub]
[red]A palindrome gone wrong?[/red]
A man, a plan, a ROOT canal...
PULLEMALL![/sub]

 

[Randy1234]

Skip you are an absolute genious. I will definitely give credit where credit is do. Looking at your logic, I can see what I was missing. Thank you so much for your help. You Rock!!!

 

[SkipVought]

Here's another small tweek...

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Code As Range
    Dim Track As Range
    Dim Cell As Range, rng As Range, iColorIndex
    
    Set Code = Range("A1:A30")
    Set Track = Range("G1:BB30")
    
    If Not Intersect(Target, Code) Is Nothing Or _
    Not Intersect(Target, Track) Is Nothing Then
        Set rng = Intersect(Track, Target.EntireRow)
        For Each Cell In rng
            With Cell
                Select Case .Value
                    Case Is > 0
                        Select Case Cells(.Row, "A").Value
                            Case "s": iColorIndex = 34
                            Case "o": iColorIndex = 50
                            Case "e": iColorIndex = 40
                            Case "f": iColorIndex = 41
                            Case "ee": iColorIndex = 7
                            Case "p": iColorIndex = 6
                            Case "": iColorIndex = xlNone
                        End Select
                    Case ""
                        iColorIndex = xlNone
                End Select
                Cell.Interior.ColorIndex = iColorIndex
                End If
            End With
        Next Cell
    End If
End Sub

Skip,
[sub]
[red]A palindrome gone wrong?[/red]
A man, a plan, a ROOT canal...
PULLEMALL![/sub]

 

[Lucky2008]

Here's another small tweek...

CODE
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Code As Range
Dim Track As Range
Dim Cell As Range, rng As Range, iColorIndex

Set Code = Range("A1:A30")
Set Track = Range("G1:BB30")

If Not Intersect(Target, Code) Is Nothing Or _
Not Intersect(Target, Track) Is Nothing Then
Set rng = Intersect(Track, Target.EntireRow)
For Each Cell In rng
With Cell
Select Case .Value
Case Is > 0
Select Case Cells(.Row, "A").Value
Case "s": iColorIndex = 34
Case "o": iColorIndex = 50
Case "e": iColorIndex = 40
Case "f": iColorIndex = 41
Case "ee": iColorIndex = 7
Case "p": iColorIndex = 6
Case "": iColorIndex = xlNone
End Select
Case ""
iColorIndex = xlNone
End Select
Cell.Interior.ColorIndex = iColorIndex
End If ''''Error?
End With
Next Cell
End If
End Sub