How to increase/decrease numbers using keystrokes enter/shift+enter?

Dear friends,
Please suggest me a code to do the following:

In a single cell I want to increase/decrease the number using the keystrokes enter and shift + enter. Initially the cell b4 should contain 0.

1. If I hid the enter key then the number should increment one by one. Suppose I want this code in cell b4 then; if I hid the enter key first time then the number in cell b4 should be 1, second time 2, third time 3, fourth time 4 and so on endlessly.
2. If I hid the key combination ‘shift + enter’ then the number should be decrease one by one till 0. If the cell contains 0 then the shift + enter stroke should not have any effect and display a pop up message ‘Hid enter key to increment the number’.
Suppose there is 4 in cell b4 and I hid a key combination shift + enter first time then then the number should be decrease by 1 showing 3 in cell b4, second time 2, third time 1, fourth time 0 and finally if it’s contains 0 and I hid shift + enter a pop message should display and no any effect in cell b4.

Any help will be highly appreciated.

Thanking you in anticipation.

Hi,

Put this code in Sheet code module :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect(Target, Range("B4")) Is Nothing Then
     Application.OnKey "~", "IncreaseValue"
     Application.OnKey "+~", "DecreaseValue"
  Else
     Application.OnKey "~"
     Application.OnKey "+~"
  End If
End Sub

Put this in Standard code module :

Private Sub IncreaseValue()
  If IsNumeric(ActiveCell.Value) Then
     If ActiveCell.Value < 0 Then
        ActiveCell.Value = 0
     Else
        ActiveCell.Value = ActiveCell.Value + 1
     End If
  Else
     ActiveCell.Value = 0
  End If
End Sub
Private Sub DecreaseValue()
  If IsNumeric(ActiveCell.Value) Then
     If ActiveCell.Value <= 0 Then
        ActiveCell.Value = 0
        MsgBox "Cannot decrease anymore"
     Else
        ActiveCell.Value = ActiveCell.Value - 1
     End If
  Else
     ActiveCell.Value = 0
  End If
End Sub

Regards

Hi karedog,
Excellent! You have done a great job beyond my imagination.

However I need a little revision in the code to make the cell b4 not editable. No one should delete a number in cell b4 nor enter any value in it manually. If anybody delete/enter any value in it then a pop up message should display 'You can not delete/enter any value!'.

I appreciate you for your excellent creation.

Best of luck and have a nice day.

Thank you.

Hi,

Many thanks for the kind words and for the reputation points

Put this code in Sheet code module :

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("B4")) Is Nothing Then
     i = AvoidEmptyCell()
  End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect(Target, Range("B4")) Is Nothing Then
     With ActiveCell.Validation
       .Delete
       .Add Type:=xlValidateCustom, _
            AlertStyle:=xlValidAlertStop, _
            Formula1:="<>"
       .ErrorMessage = strValidationErrorMessage
     End With

     Application.OnKey "~", "IncreaseValue"
     Application.OnKey "+~", "DecreaseValue"
  Else
     Application.OnKey "~"
     Application.OnKey "+~"
  End If
End Sub

Put this in Standard code module :

Public Const strValidationErrorMessage = "You can not delete/enter any value!"
Function AvoidEmptyCell()
  If IsEmpty(ActiveCell) Then
     MsgBox strValidationErrorMessage
     Application.EnableEvents = False
       Application.Undo
     Application.EnableEvents = True
     AvoidEmptyCell = 1
  Else
     AvoidEmptyCell = 0
  End If
End Function
Private Sub IncreaseValue()
  If AvoidEmptyCell() = 1 Then Exit Sub
  If IsNumeric(ActiveCell.Value) Then
     If ActiveCell.Value < 0 Then
        ActiveCell.Value = 0
     Else
        ActiveCell.Value = ActiveCell.Value + 1
     End If
  Else
     ActiveCell.Value = 0
  End If
End Sub
Private Sub DecreaseValue()
  If AvoidEmptyCell() = 1 Then Exit Sub
  If IsNumeric(ActiveCell.Value) Then
     If ActiveCell.Value <= 0 Then
        ActiveCell.Value = 0
        MsgBox "Cannot decrease anymore"
     Else
        ActiveCell.Value = ActiveCell.Value - 1
     End If
  Else
     ActiveCell.Value = 0
  End If
End Sub

Regards

Hi,
Thank you. I'm getting compile error 1004 on the following line.

Application.Undo

Thank you,

Oh sorry, that is happenned when the undo stack is still empty.

Please change Function AvoidEmptyCell() to this :

Function AvoidEmptyCell()
  If IsEmpty(ActiveCell) Then
     MsgBox strValidationErrorMessage
     Application.EnableEvents = False
       On Error Resume Next
          Application.EnableEvents = False
            Application.Undo
          Application.EnableEvents = True
       On Error GoTo 0
     Application.EnableEvents = True
     AvoidEmptyCell = 1
  Else
     AvoidEmptyCell = 0
  End If
End Function

Regards

Hi Keredog,
Thank you for quick response. Now the undo problem is solved but it's not increasing/decreasing the numbers after hidding enter/shift + enter key. It should work as before but only the manual entry/delete should prevent.

Increase-decrease numbers automatically 2

Thank you.

Of course it will not if the value of B4 when the workbook opened is already filled with value outside the scope of validation or is empty.

You must initialize the value of B4 programmatically (cannot directly edit the cell since the worksheet events has already running) using code like this :

Sub FirstTimeSetValue()
  Sheet1.Range("B4").Value = 7
End Sub

Regards

Dear Karedog,
Thank you. Now it's working absolutely fine.

Extremely sorry for trouble again. I want a prefix before a number which is on cell m1 on 'Support' sheet. In short a number should be a combination of cell m1 Support sheet and a number in b4 sheet1. For ex. Suppose a cell m1 Support sheet contains 'abc no.' and initially b4 contains 0 then the output should as follows:
abc no. 0
and so on. After hidding enter/shift+enter key only number will change as per the programme you have created. And not prefix. It will change when I edit it in m1 Support sheet only. That is all right. Only I want a prefix from Support sheet cell m1 before the number.

This is a final revision then the problem will be solved.

Thank you and sorry for trouble again.

Have a nice day.

Dear mso3,

I don't catch you question very clearly, but I will try my best.

If you want to auto update the value in cell M1 on sheet "Support" then put this formula at cell M1 :

="abc no. " & Sheet1!B4

But if you want to update value in M1 only at your will (manually) , then put this code in sheet "Support" module :

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("M1")) Is Nothing Then
     Application.EnableEvents = False
       ActiveCell.Value = "abc no. " & Sheet1.Range("B4").Value
     Application.EnableEvents = True
  End If
End Sub

This will only update the cell value only if you do a change in this cell (change this cell content to other value, or just hit del or F2-Enter will do).

Hope that my answers can help you solve your problem.

Regards

Hi Karedog,
Thank you. Sorry I don't want this. I want a prefix which is on cell m1 Support sheet on sheet1 cell b4 as:
abc no. 0
abc no. 1
abc no. 2
abc no. 3
abc no. 4
And so on.

abc no. is on cell m1 Support sheet. I want this prefix before the number on sheet1 cell b4.

This output should be on sheet1 cell b4.

Sub FirstTimeSetValue()
  Sheet1.Range("B4").Value = worksheet("Supportm1") & sheet1("b4").value
End Sub

However it's giving error.

Hope this will clear your confusion to achieve the target.

Thank you.

So the code above is exactly reversed version of what you are expecting.

Since now we work on different sheet, so the SelectionChange() event must be moved from Sheet module to Workbook module.
Please change all of code to this :

Code of Sheet1 :

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("B4")) Is Nothing Then
     i = AvoidEmptyCell()
  End If
End Sub

Code of Sheet Supportm1 :

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("M1")) Is Nothing Then
     Application.EnableEvents = False
       Sheet1.Range("B4").NumberFormat = """" & Target.Value & """" & "#0"
     Application.EnableEvents = True
  End If
End Sub

Code of ThisWorkbook :

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  If Sh.Index = Sheet1.Index Then
     If Not Intersect(Target, Range("B4")) Is Nothing Then
        With ActiveCell.Validation
          .Delete
          .Add Type:=xlValidateCustom, _
             AlertStyle:=xlValidAlertStop, _
             Formula1:="<>"
          .ErrorMessage = strValidationErrorMessage
        End With

        Application.OnKey "~", "IncreaseValue"
        Application.OnKey "+~", "DecreaseValue"
     Else
        Application.OnKey "~"
        Application.OnKey "+~"
     End If
  Else
     Application.OnKey "~"
     Application.OnKey "+~"
  End If
End Sub

Code of Standard module :

Public Const strValidationErrorMessage = "You can not delete/enter any value!"
Function AvoidEmptyCell()
  If IsEmpty(ActiveCell) Then
     MsgBox strValidationErrorMessage
     Application.EnableEvents = False
       On Error Resume Next
          Application.EnableEvents = False
            Application.Undo
          Application.EnableEvents = True
       On Error GoTo 0
     Application.EnableEvents = True
     AvoidEmptyCell = 1
  Else
     AvoidEmptyCell = 0
  End If
End Function
Private Sub IncreaseValue()
  If AvoidEmptyCell() = 1 Then Exit Sub
  If IsNumeric(ActiveCell.Value) Then
     If ActiveCell.Value < 0 Then
        ActiveCell.Value = 0
     Else
        ActiveCell.Value = ActiveCell.Value + 1
     End If
  Else
     ActiveCell.Value = 0
  End If
End Sub
Private Sub DecreaseValue()
  If AvoidEmptyCell() = 1 Then Exit Sub
  If IsNumeric(ActiveCell.Value) Then
     If ActiveCell.Value <= 0 Then
        ActiveCell.Value = 0
        MsgBox "Cannot decrease anymore"
     Else
        ActiveCell.Value = ActiveCell.Value - 1
     End If
  Else
     ActiveCell.Value = 0
  End If
End Sub

Regards

Hello Karedog,
Excellent! Excellent! Excellent!

Now it's working absolutely fine as per my requirement. I personally by heart appreciate you for taking trouble to solve my problem.

I'm glad to receive a excellent solution from you today.

Have a nice day.

Thank you.

Hi mso3,

I am glad that you finally have solved this problem.
It is very nice to cooperate with you.
Have a great weekend.

Regards

Hello Karedog,
Sorry for trouble again. To speed up the work and avoide one step I need a little amendment in the code so I post here gain.

I enter register no. in cell g7 register sheet and then hit enter key. At this point I want to change the receipt no. in b4 automatically change.

For example:
If I enter register no. in cell g7 register sheet then the receipt no. in cell b4 should change automatically as present but only the difference is that we are not hitting enter key on cell b4 here. Wwe hit enter key on cell g7 only then we want the receipt no. cell b4 change increase/decrease.

Will you please do this little amendment for me?

Sorry for trouble.

Thanking you,

Hi,

When you press enter at cell G7, the value of cell B4 should be increased, but does the value of cell G7 itself also should be increased or not ?

Regards

Hello Karedog,
Good morning!

Thankyou for your kind response to amend the code as per my requirement.

No, only the receipt number in b4 should change and not register number in g7. I will change the number in g7 manually.
Thank you and have a nice day!

Hi omb3, good afternoon.

Please look at the code below, maybe it is what you need.

Sheet1 (Register) code :

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("B4")) Is Nothing Then
     MsgBox strValidationErrorMessage
     On Error Resume Next
        Application.EnableEvents = False
          Application.Undo
        Application.EnableEvents = True
     On Error GoTo 0
  End If

  If Not Intersect(Target, Range("G7")) Is Nothing Then
     If AvoidEmptyCell() = 1 Then Exit Sub

     Application.EnableEvents = False
       Range("B4").Value = Target.Value
     Application.EnableEvents = True
  End If
End Sub

Sheet2 (Support) code :

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("M1")) Is Nothing Then
     Application.EnableEvents = False
       Sheets("Register").Range("B4").NumberFormat = """" & Target.Value & """" & "#0"
     Application.EnableEvents = True
  End If
End Sub

ThisWorkbook code :

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  If Sh.Index = Sheets("Register").Index Then
     If Not Intersect(Target, Range("G7")) Is Nothing Then
        With ActiveCell.Validation
          .Delete
          .Add Type:=xlValidateDecimal, _
               AlertStyle:=xlValidAlertStop, _
               Operator:=xlBetween, _
               Formula1:=0, _
               Formula2:=999999999
          .ErrorMessage = strValidationErrorMessage
        End With

        Application.OnKey "~", "IncreaseValue"
        Application.OnKey "+~", "DecreaseValue"
     Else
        Application.OnKey "~"
        Application.OnKey "+~"
     End If
  Else
     Application.OnKey "~"
     Application.OnKey "+~"
  End If
End Sub

Standard Module code :

Public Const strValidationErrorMessage = "Only number allowed !"
Function AvoidEmptyCell()
  If IsEmpty(ActiveCell) Then
     MsgBox strValidationErrorMessage
     On Error Resume Next
        Application.EnableEvents = False
          Application.Undo
        Application.EnableEvents = True
     On Error GoTo 0
     AvoidEmptyCell = 1
  Else
     AvoidEmptyCell = 0
  End If
End Function
Private Sub IncreaseValue()
  If AvoidEmptyCell() = 1 Then Exit Sub

  Application.EnableEvents = False
    With Sheets("Register").Range("B4")
      If IsNumeric(.Value) Then
         If .Value < 0 Then
            .Value = 0
         Else
            .Value = .Value + 1
         End If
      End If
    End With
  Application.EnableEvents = True
End Sub
Private Sub DecreaseValue()
  If AvoidEmptyCell() = 1 Then Exit Sub

  Application.EnableEvents = False
    With Sheets("Register").Range("B4")
      If IsNumeric(.Value) Then
         If .Value <= 0 Then
            .Value = 0
            MsgBox "Cannot decrease anymore"
         Else
            .Value = .Value - 1
         End If
      End If
    End With
  Application.EnableEvents = True
End Sub
Sub FirstTimeSetValue()
  Sheets("Register").Range("G7").Value = 2
End Sub

Regards

Hello Karedog,
Good evening!

Excellent! Thank you. Ok! It's working fine but a little amendment is require to meet my requirement.

Everything is ok but the number in cell b4 is not the same as g7. I don't want to transfer the number in cell g7 to b4. Both are different. The number in cell b4 is a receipt number which should start from 1 and no matter which number is in cell g7.

For example:

No matter which number I enter in cell g7.

First time the initial value of cell b4 should be 0 which I have set now. After entering any number in cell g7 and after hitting enter key on cell g7 the number in cell b4 should change to 1; Second time 2; third time 3 and so on endlessly. Same to decrease number.

Thank you,

Hello,

I'm terrrible sorry, I missed your new post, I just realized it when browsing my older posts.

To meet your requirement, change the code in post #18 for Sheet1 to this :
Sheet1 (Register) code :

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("B4")) Is Nothing Then
     MsgBox strValidationErrorMessage
     On Error Resume Next
        Application.EnableEvents = False
          Application.Undo
        Application.EnableEvents = True
     On Error GoTo 0
  End If
End Sub

Regards

Hello Karedog,
Excellent! Now it's perfect as per my requirement.

I appreciate you for your kind cooperation and guidance to solve my problem.

Thank you and have a nice day.