Repititous code - help to shorten

[BobJacksonNCI]

Hello,
Thread thread707-1169212 got me started in the right direction, but ...

The worksheet is used to tally survey results.
It's working well and I want to make it better.
Each row corresponds to a question number.
In use, the code locks cursor positioning into B and the User types the number for the box checked on the card. The code increments the count for that response for that question and moves the cursor to the next row.
All good.
Buttons were added to auto-record when the card shows all 1's, all 2's, etc. Users have asked that for the All X's buttons, I just set the value for all questions but have a separate "commit" button. That way, when a card is scored that has all 1's except for a few other values, they can use the All 1's button, adjust the individual questions as needed, and then use the "commit" button to record the scores. (Difficult to explain when you can't see the worksheet.)
If you have followed me, the difficulty in doing this is the way I wrote the code. I used the built-in event, "Worksheet_Change" to react to a score being entered. In that routine, I check to see which row I'm on and react accordingly. But that code is repeated for every row because I couldn't make a tight loop do the job.
Following is the beginning of the routine and the code for the first two rows tallied - it is repeated 55 times. If I could make a tight loop out of the code, I could easily do what the Users requested.
Thanks in advance for your assistance!
Bob

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Target
If booSkipChg Then 'ROUTINE EXECUTES FOR *EVERY* CHANGE IN THE WORKSHEET!
Exit Sub 'IF CLEARING CELLS, SKIP
End If
If Target.Column <> 2 Then 'TEST IF TARGET CELL IS IN COLUMN B (2) ONLY
Exit Sub
End If
If Target.Value < 1 Or Target.Value > 5 Then
ActiveCell.Offset(rowoffset:=0, columnoffset:=-1).Activate
response = MsgBox("You must type a value between 1 and 5", vbCritical + vbOKOnly, "ERROR")
Exit Sub
End If
If .Address = [$b$6].Address Then
Select Case .Value
Case 1
With [$c$6]
.Value = .Value + 1
End With
Case 2
With [$d$6]
.Value = .Value + 1
End With
Case 3
With [$e$6]
.Value = .Value + 1
End With
Case 4
With [$f$6]
.Value = .Value + 1
End With
Case 5
With [$g$6]
.Value = .Value + 1
End With
End Select
Range("$B$7").Activate
Exit Sub
End If
If .Address = [$b$7].Address Then
Select Case .Value
Case 1
With [$c$7]
.Value = .Value + 1
End With
Case 2
With [$d$7]
.Value = .Value + 1
End With
Case 3
With [$e$7]
.Value = .Value + 1
End With
Case 4
With [$f$7]
.Value = .Value + 1
End With
Case 5
With [$g$7]
.Value = .Value + 1
End With
End Select
Range("$B$8").Activate
Exit Sub
End If
...
... 'Following is the end, MANY lines later
...
Range("$B$6").Activate
Exit Sub
End If
End With
End Sub

 

[SkipVought]

Hi,

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
   With Target
        If booSkipChg Then 'ROUTINE EXECUTES FOR *EVERY* CHANGE IN THE WORKSHEET!
            Exit Sub       'IF CLEARING CELLS, SKIP
        End If
        If Target.Column <> 2 Then 'TEST IF TARGET CELL IS IN COLUMN B (2) ONLY
            Exit Sub
        End If
        If Target.Value < 1 Or Target.Value > 5 Then
            ActiveCell.Offset(rowoffset:=0, columnoffset:=-1).Activate
            response = MsgBox("You must type a value between 1 and 5", vbCritical + vbOKOnly, "ERROR")
            Exit Sub
        End If
      Select Case .Address
        Case [B6].Address, [B7].Address
            If .Value >= 1 And .Value <= 5 Then
              .Offset(0, .Value).Value = .Offset(0, .Value).Value + 1
              .Offset(1).Select
              Exit Sub
            End If
      End Select
    End With
End Sub

Skip,

_{[red]Be Advised![/red] The Vinyards of Texas have produced a wine with diuretic dimishment and urethric relief...
Pinot More!}