Looping to Format Cells

[dcoledc]

I have the following code in the worksheet change mod and I want to clean it up:

If Range("B13") = 1 Then
    Range("U6:Y6").Interior.Color = vbYellow
Else
    Range("U6:Y6").Interior.Color = vbWhite
End If
If Range("C13") = 1 Then
    Range("U7:Y7").Interior.Color = vbYellow
Else
    Range("U7:Y7").Interior.Color = vbWhite
End If
If Range("D13") = 1 Then
    Range("U8:Y8").Interior.Color = vbYellow
Else
    Range("U8:Y8").Interior.Color = vbWhite
End If
If Range("E13") = 1 Then
    Range("U9:Y9").Interior.Color = vbYellow
Else
    Range("U9:Y9").Interior.Color = vbWhite
End If
If Range("F13") = 1 Then
    Range("U10:Y10").Interior.Color = vbYellow
Else
    Range("U10:Y10").Interior.Color = vbWhite
End If
If Range("G13") = 1 Then
    Range("U11:Y11").Interior.Color = vbYellow
Else
    Range("U11:Y11").Interior.Color = vbWhite
End If
If Range("H13") = 1 Then
    Range("U12:Y12").Interior.Color = vbYellow
Else
    Range("U12:Y12").Interior.Color = vbWhite
End If

That is actually only about 1/3 of the code. I repeat that over and over.

I did not use conditional formatting b/c I copy and paste these cells over and over and when I do that the formatting goes with it and bogs excel down. I couldn't do paste special b/c some of the cells are merged. Thus I resorted to VBA.

There has got to be a better way to do what I am doing, perhaps a loop.

 

[dcoledc]

Thanks again, I will give that a try. Currently, though, I am trying to eliminate the merged cells, as I like your orignal suggestion.

 

[dcoledc]

Success! Accept for one sheet, I was able to eliminate the merged cells. I took the code you gave and was able to make it work. Whether, my solution is the best or not, I don't know, but it works. I got the idea from your last post.

    Dim rng As Range, cell As Range
    If Not Intersect(Range("B15:H15, B20:M20, B24:H24"), Target) Is Nothing Then
    
        ActiveSheet.Unprotect Password:="17Lj041kM"
        
        For Each cell In Intersect(Range("B15:H15, B20:M20, B24:H24"), Target)
            
            Select Case cell.Row
                Case 15
                If cell.Column <= 2 Then
                    Set rng = Range("T6:U6").Offset(cell.Column - 2)
                Else
                    Set rng = Range("T6:U6").Offset(cell.Column - 1)
                End If
                Case 20
                    Set rng = Range("T16:U16").Offset(cell.Column - 2)
                Case 24
                If cell.Column <= 2 Then
                    Set rng = Range("T30:U30").Offset(cell.Column - 3)
                Else
                    If cell.Column = 7 Then
                        Set rng = Range("T30:U30").Offset(cell.Column - 1)
                    Else
                        If cell.Column = 8 Then
                            Set rng = Range("T30:U30").Offset(cell.Column - 0)
                        Else
                            Set rng = Range("T30:U30").Offset(cell.Column - 2)
                        End If
                    End If
                End If
            End Select
            If cell.Value = 1 Then
                rng.Interior.Color = vbYellow
            Else
                rng.Interior.Color = vbWhite
            End If
            
        Next cell

Thanks again, chalk it up to another problem solved.