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.

 

[AlphaFrog]

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Range("B13:T13"), Target) Is Nothing Then
        If Target.Value = 1 Then
            Range("U6:Y6").Offset(Target.Column - 2).Interior.Color = vbYellow
        Else
            Range("U6:Y6").Offset(Target.Column - 2).Interior.Color = vbWhite
        End If
    End If

End Sub

 

[dcoledc]

P.S. Everytime I change one cell, all this code runs. How do I make only the code run for the cell that is changed? Keep in mind this code is in the worksheet change module

 

[dcoledc]

Thanks, that is awesome. Man, do I have a lot to learn.

 

[dcoledc]

AlphaFrog, if your are still out there, I could use some more help. I have been trying to adapt your code to fit my needs and b/c I don't fully understand if, I can't.

One of the ranges of cells contains some merged cells. I get an error on that one, so I though I would jsut pick up after the merged cell but I can't get the code to work when I do that.

The ranges of cells in question are

B13:H13
B17:N17 (where I7 and J17 are merged)
B21:H21

Here is what I have:

    If Not Intersect(Range("B17:H17"), Target) Is Nothing Then
        ActiveSheet.Unprotect Password:="17Lj041kM"
        If Target.Value = 1 Then
            Range("U13:Y13").Offset(Target.Column - 2).Interior.Color = vbYellow
        Else
            Range("U13:Y13").Offset(Target.Column - 2).Interior.Color = vbWhite
        End If
        ActiveSheet.Protect Password:="17Lj041kM"
    End If
 
    If Not Intersect(Range("B17:N17"), Target) Is Nothing Then
        ActiveSheet.Unprotect Password:="17Lj041kM"
        If Target.Value = 1 Then
            Range("U13:Y13").Offset(Target.Column - 2).Interior.Color = vbYellow
        Else
            Range("U13:Y13").Offset(Target.Column - 2).Interior.Color = vbWhite
        End If
        ActiveSheet.Protect Password:="17Lj041kM"
    End If
 
    If Not Intersect(Range("B21:H21"), Target) Is Nothing Then
        ActiveSheet.Unprotect Password:="17Lj041kM"
        If Target.Value = 1 Then
            Range("U25:Y25").Offset(Target.Column - 2).Interior.Color = vbYellow
        Else
            Range("U25:Y25").Offset(Target.Column - 2).Interior.Color = vbWhite
        End If
        ActiveSheet.Protect Password:="17Lj041kM"
    End If

The middle set of code works when I enter the one into the cells, but when I delete the one from the merged cells, I get a runtime error: type mismatch.

I suppose I could do an errorhandler, but I would rather gain some understanding on how the code works so I can fix it.

I don't understand where the starting point is for the offset.

Thought please.

 

[AlphaFrog]

I don't understand where the starting point is for the offset.

Range("U13:Y13").Offset(Target.Column - 2)

This code will offset n rows from U13:Y13 based on the column number of the Target (changed) cell.

So if the Target cell is say B17, its column number is 2 (B), so the row offset from U13:Y13 is 2-2 or 0.

If the Target cell is say D17, its column number is 4 (D), so the row offset from U13:Y13 is 4-2 or 2 (U15:Y15)


The problem with merged cells and using...
If Target.Value = 1 Then
...is the .Value = 1 comparison can only be used on a reference to one cell and not a range of cells. If Target is a merged cell, then it's a range of cells. A quick fix could be to use...
If Target(1).Value = 1 Then
...which will reference just the 1st cell in Target whether it's one or a range of cells.

One other issue the code has is if you were to select a range of cells (say B17:E17) to clear the entries, the code wouldn't work on each cell in the selection.

This will loop through each cell in the selection

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim rng As Range, cell As Range
    
    If Not Intersect(Range("B13:H13, B17:N17, B21:H21"), Target) Is Nothing Then
    
        ActiveSheet.Unprotect Password:="17Lj041kM"
        
        For Each cell In Intersect(Range("B13:H13, B17:N17, B21:H21"), Target)
            
            Select Case cell.Row
                Case 13
                    Set rng = Range("U6:Y6").Offset(cell.Column - 2)
                Case 17
                    Set rng = Range("U13:Y13").Offset(cell.Column - 2)
                Case 21
                    Set rng = Range("U25:Y25").Offset(cell.Column - 2)
            End Select
            
            If cell.Value = 1 Then
                rng.Interior.Color = vbYellow
            Else
                rng.Interior.Color = vbWhite
            End If
            
        Next cell
        
        ActiveSheet.Protect Password:="17Lj041kM"
        
    End If
    
End Sub

 

[dcoledc]

Thank you for the explanation. I now understand the offset and I believe I have some concept of your suggestion. I will play with it to see if I can get it to work.

On first attempt at just pasting your code, the error no longer pops up, which is great, but when I reach the cell after the merged cells, the offset is off by one.

I will continue to try and make it work, however, any suggestions?

Thanks again.

 

[AlphaFrog]

I didn't know if you wanted to skip a row for the merged cells or not.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim rng As Range, cell As Range
    
    If Not Intersect(Range("B13:H13, B17:N17, B21:H21"), Target) Is Nothing Then
    
        ActiveSheet.Unprotect Password:="17Lj041kM"
        
        For Each cell In Intersect(Range("B13:H13, B17:N17, B21:H21"), Target)
            
            Select Case cell.Row
                Case 13
                    Set rng = Range("U6:Y6").Offset(cell.Column - 2)
                Case 17
[COLOR="Red"]                    If cell.Column <= 10 Then
                        'If changed cell is column B to J
                        Set rng = Range("U13:Y13").Offset(cell.Column - 2)
                    Else
                        'If changed cell is column K to N
                        Set rng = Range("U13:Y13").Offset(cell.Column - 3)
                    End If[/COLOR]
                Case 21
                    Set rng = Range("U25:Y25").Offset(cell.Column - 2)
            End Select
            
            If cell.Value = 1 Then
                rng.Interior.Color = vbYellow
            Else
                rng.Interior.Color = vbWhite
            End If
            
        Next cell
        
        ActiveSheet.Protect Password:="17Lj041kM"
        
    End If
    
End Sub

 

[dcoledc]

Thanks yet again. I very much appreciate your help and would love your continued help if you wish, however, things are getting more and more complicated.

This code that is being worked on is meant to be used on 3 sheets. The other 2 sheets don't just have a few cells merged vertically, but they have series of cells merged horizontally.

I played with the code to try and make it work and again b/c I don't fully grasp everything you are doing, I am getting mixed results. Sometimes it won't do anything to a cell when I think it will.

I am trying to figure a way to elminate the merged cells to eliminate the problem, but I have yet to come up with a solution.

As much as I don't like my original, lengthy code, is there a way to take what I have done and simply prevent all the code from running each time one of the cells is changed?

I am grasping at straws. I don't know the best solution, but I also don't want to take advantage of the forum either.

Thoughts?

 

[AlphaFrog]

As much as I don't like my original, lengthy code, is there a way to take what I have done and simply prevent all the code from running each time one of the cells is changed?)

The Worksheet_Change event procedure is triggered when any cell on the worksheet is changed. You can have a test at the beginning of the procedure to only "do something" when certain cells are changed. In the earlier code, that's what the Intersect line does.

The following example only does something when there are changes to cells B13:H13, B17:N17, B21:H21
All other cell changes would be ignored.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Not Intersect(Range("B13:H13, B17:N17, B21:H21"), Target) Is Nothing Then
    
          [COLOR="Green"]' Do something here.[/COLOR]
        
    End If
    
End Sub