Solved: Adding More Cell Ranges to BeforeDoubleClick and BeforeRightClick Macro

[coliervile]

The present coding allows the user to Left Double-Click (the cell in white) to add one to the current cell value and Right Double-Click (the cells colored white) to subtract one from the cells value. I need to add more cell ranges (the cells hightlighted in YELOW) to the current BeforeDoubleClick and BeforeRightClick macro. The coding in the following worksheel was provided by "XLD"....thanks Bob.

Best regards,

Charlie

[JimmyTheHand]

Charlie,

Try this code. It's quite different from what you uploaded, but I think it will suit your needs.
[vba]
Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If ValidTarget(Target) Then
If IsNumeric(Target.Value) Then Target.Value = Target.Value + 1
End If
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If ValidTarget(Target) Then
If IsNumeric(Target.Value) Then Target.Value = Target.Value - 1
End If
End Sub

Function ValidTarget(Tgt As Range) As Boolean
Dim T1 As Range, T2 As Range

ValidTarget = False

Set T1 = Range("G10:G18, N10:N11, N13:N15, J18:K18")
Set T2 = Cells((Tgt.Row - 10) Mod 9 + 10, (Tgt.Column - 6) Mod 9 + 6)
If (Not Intersect(T1, T2) Is Nothing) And _
(Not Intersect(Tgt, Range("F10:CH117")) Is Nothing) Then ValidTarget = True

Set T1 = Range("J5, J6, J119, I126:N134")
Set T2 = Cells(Tgt.Row, (Tgt.Column - 6) Mod 9 + 6)
If (Not Intersect(T1, T2) Is Nothing) And (Tgt.Row > 5) And (Tgt.Column < 87) Then ValidTarget = True

If Not Intersect(Range("Q7, T7, AR7, AU7"), Tgt) Is Nothing Then ValidTarget = True

End Function
[/vba]
Private Sub Worksheet_Change was left unchanged.

HTH
Jimmy

[coliervile]

Thanks JimmyTheHand for youe time and coding. It did everything with the exception of row 5. Starting at J5 when these cells are double-clicked nothing happens. Your coding does include, I believe, this range, but doesn't put a one in the cell???

Best regards,

Charlie

[coliervile]

Thanks JimmyTheHand for youe time and coding. It did everything with the exception of row 5. Starting at J5 when these cells are double-clicked nothing happens. Your coding does include, I believe, this range, but doesn't put a one in the cell???

Best regards,

Charlie

[Bob Phillips]

[vba]

Function ValidTarget(Tgt As Range) As Boolean
Dim T1 As Range, T2 As Range

ValidTarget = False

Set T1 = Range("G10:G18, N10:N11, N13:N15, J18:K18")
Set T2 = Cells((Tgt.Row - 10) Mod 9 + 10, (Tgt.Column - 6) Mod 9 + 6)
If (Not Intersect(T1, T2) Is Nothing) And _
(Not Intersect(Tgt, Range("F10:CH117")) Is Nothing) Then ValidTarget = True

Set T1 = Range("J5, J6, J119, I126:N134")
Set T2 = Cells(Tgt.Row, (Tgt.Column - 6) Mod 9 + 6)
If (Not Intersect(T1, T2) Is Nothing) And (Tgt.Column > 5) And (Tgt.Column < 87) Then ValidTarget = True

If Not Intersect(Range("Q7, T7, AR7, AU7"), Tgt) Is Nothing Then ValidTarget = True

End Function
[/vba]

[JimmyTheHand]

My mistake, sorry.

[vba]If (Not Intersect(T1, T2) Is Nothing) And (Tgt.Row > 5) And (Tgt.Column < 87) Then ValidTarget = True[/vba]
must be changed into
[vba]If (Not Intersect(T1, T2) Is Nothing) And (Tgt.Column > 5) And (Tgt.Column < 87) Then ValidTarget = True[/vba]
Also, the worksheet events should be modified (changes are highlighted):
[vba]Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If ValidTarget(Target) Then
Cancel = True
If IsNumeric(Target.Value) Then Target.Value = Target.Value + 1
End If
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If ValidTarget(Target) Then
Cancel = True
If IsNumeric(Target.Value) Then Target.Value = Target.Value - 1
End If
End Sub[/vba]
Jimmy

[coliervile]

Good day to you Sir. How are thing going for you Bob? Your coding for this issue worked and I'll mark it close.

Bob second note: I came across a glitch in some coding you helped me with. I'll have to wait untill later to open a new thread to address it.

Best regards,

Charlie

[Bob Phillips]

BTW, this is the changes to the original code

[vba]

Option Explicit

Const WS_RANGE As String = "C:C"
Const WS_RANGE2 As String = "Q7,T7,AR7,AU7"
Const WS_RANGE_ROW As String = "10:117"
Const WS_RANGE_COL1 As String = "G:CA"
Const WS_RANGE_ROW2 As String = "10:117"
Const WS_RANGE_COL2 As String = "N:CH"
Const WS_RANGE_ROW3 As String = "5:6"
Const WS_RANGE_ROW4 As String = "119:119"

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Dim mpStart As Range
Dim i As Long

Cancel = True

With Target

If IsTarget(Target) Then

If IsNumeric(.Value) Then

.Value = .Value + 1
End If
ElseIf Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then

If .Row > 10 And .Row < 118 And .Row Mod 9 <> 1 Then

Set mpStart = Range("F" & (.Row \ 10 + 1) * 9)
End If

For i = 2 To 9

If mpStart.Offset(0, (i - 1) * 9 + 8).Value = "" And _
mpStart.Offset(0, (i - 1) * 9 - 1).Value = .Cells(1, 1).Value Then

mpStart.Offset(0, (i - 1) * 9 + 8).Value = Target.Value
Exit For
End If
Next i
End If
'Cancel = True
End With
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

With Target

If IsTarget(Target) Then

If IsNumeric(.Value) Then

.Value = .Value - 1
End If
End If
End With
'Cancel = True

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Const WS_RANGE As String = "C:C"
Dim mpStart As Range
Dim i As Long

On Error GoTo ws_exit
Application.EnableEvents = False

If Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then

With Target

If .Row > 10 And .Row < 118 And .Row Mod 9 <> 1 Then

Set mpStart = Range("F" & (.Row \ 10 + 1) * 9)
End If

For i = 1 To 9

If mpStart.Offset(0, (i - 1) * 9 + 8).Value = "" Then

mpStart.Offset(0, (i - 1) * 9 + 8).Value = Target.Value
Exit For
End If
Next i
End With
End If

ws_exit:
Application.EnableEvents = True
End Sub

Private Function IsTarget(ByVal Target As Range) As Boolean

If (Not Intersect(Target, Me.Range(WS_RANGE_ROW)) Is Nothing And _
(Not Intersect(Target, Me.Range(WS_RANGE_COL1)) Is Nothing And _
Target.Column Mod 9 = 7) _
) Or _
_
((Not Intersect(Target, Me.Range(WS_RANGE_ROW)) Is Nothing And _
Not (Target.Row Mod 9 = 0 Or _
Target.Row Mod 9 = 3 Or _
Target.Row Mod 9 = 7 Or _
Target.Row Mod 9 = 8) _
) And _
(Not Intersect(Target, Me.Range(WS_RANGE_COL2)) Is Nothing And _
Target.Column Mod 9 = 5) _
) Or _
_
(Not Intersect(Target, Me.Range(WS_RANGE_ROW3)) Is Nothing And _
Target.Column Mod 9 = 1) Or _
_
(Not Intersect(Target, Me.Range(WS_RANGE_ROW4)) Is Nothing And _
Target.Column Mod 9 = 1) Or _
_
Not Intersect(Target, Me.Range(WS_RANGE2)) Is Nothing Then

IsTarget = True
End If
End Function
[/vba]

[coliervile]

Thanks JimmyTheHand I'll have to take a look later, getting ready to head out, at your suggestion.

Best regards,

Charlie

[coliervile]

Thanks Bob and I'll open that other thread later today.

Best regards,

Charlie

[coliervile]

Bob would I get compile errors with the tick mark on the left in red?

Best regards,

Charlie

[VBA]Private Function ValidTarget(ByVal Target As Range) As Boolean

If (Not Intersect(Target, Me.Range(WS_RANGE_ROW)) Is Nothing And _
(Not Intersect(Target, Me.Range(WS_RANGE_COL1)) Is Nothing And _
Target.Column Mod 9 = 7) _
) Or _
_
((Not Intersect(Target, Me.Range(WS_RANGE_ROW)) Is Nothing And _
Not (Target.Row Mod 9 = 0 Or _
Target.Row Mod 9 = 3 Or _
Target.Row Mod 9 = 7 Or _
Target.Row Mod 9 = 8) _
) And _
(Not Intersect(Target, Me.Range(WS_RANGE_COL2)) Is Nothing And _
Target.Column Mod 9 = 5) _
) Or _
_
(Not Intersect(Target, Me.Range(WS_RANGE_ROW3)) Is Nothing And _
Target.Column Mod 9 = 1) Or _
_
(Not Intersect(Target, Me.Range(WS_RANGE_ROW4)) Is Nothing And _
Target.Column Mod 9 = 1) Or _
_
Not Intersect(Target, Me.Range(WS_RANGE2)) Is Nothing Then

ValidTarget = True
End If
End Function [/VBA]

[Bob Phillips]

Shouldn't do, that is the only way you can include what is effectively a break line in an If statement. I do it for readability.

[coliervile]

Bob I get a Compile Error: Syntax Error at this ppoint in the coding If (Not Intersect(Target, Me.Range(WS_RANGE_ROW)) Is Nothing And _
(Not Intersect(Target, Me.Range(WS_RANGE_COL1)) Is Nothing And _
Target.Column Mod 9 = 7) _
) Or _
_

I'm using Excel 2003... if it makes a difference.

Best regards,

Charlie

[coliervile]

Here's how the code actually shows up:

[VBA]Private Function IsTarget(ByVal Target As Range) As Boolean

If (Not Intersect(Target, Me.Range(WS_RANGE_ROW)) Is Nothing And _
(Not Intersect(Target, Me.Range(WS_RANGE_COL1)) Is Nothing And _
Target.Column Mod 9 = 7) _
) Or _
_
((Not Intersect(Target, Me.Range(WS_RANGE_ROW)) Is Nothing And _
Not (Target.Row Mod 9 = 0 Or _
Target.Row Mod 9 = 3 Or _
Target.Row Mod 9 = 7 Or _
Target.Row Mod 9 = 8) _
) And _
(Not Intersect(Target, Me.Range(WS_RANGE_COL2)) Is Nothing And _
Target.Column Mod 9 = 5) _
) Or _
_
(Not Intersect(Target, Me.Range(WS_RANGE_ROW3)) Is Nothing And _
Target.Column Mod 9 = 1) Or _
_
(Not Intersect(Target, Me.Range(WS_RANGE_ROW4)) Is Nothing And _
Target.Column Mod 9 = 1) Or _
_
Not Intersect(Target, Me.Range(WS_RANGE2)) Is Nothing Then

IsTarget = True
End If
End Function[/VBA]

Best regards,

Charlie

[JimmyTheHand]

Put one SPACE before all those underlines at the left end.

Jimmy

[coliervile]

Thanks JimmyTheHand for your suggestion and it did work. In the coding that "xld provided some of the cells didn't work??? I've included the worksheet with "xld" coding and put arrows to all of cells that didn't work with the right and left click.

Best regards,

Charlie

[Bob Phillips]

No attachment.

[Bob Phillips]

Put one SPACE before all those underlines at the left end.

Jimmy

Sorry about that. When creating the code the indents align it and then VBA automatically positions it.

[coliervile]

Let me try to download the file once more....

Best regards,

Charlie

[coliervile]

I would like to add all of the cells coloured in yellow on the attached worksheet to the left and right double-click funtion of adding and subtracting one from the cells value.