Keydown Keycode not working for mouse click

X

XrayLemi

Board Regular
Joined
Aug 1, 2018
Messages
153
Office Version
  1. 365
Platform
  1. Windows
I thought I was getting better at this but again I am stumped.

I had posted something nearly Identical to this recently. I didn't get a reply, I even thought I had found an answer. However, This is only partly true.
Here is the link to my original post. Unlock a cell with a ComboBox entry

The latest code is slightly different than the original post. It now works without using data validation. Neither the code in the original post,
or the code in this post will work with a mouse click.

This code "works" with a ComboBox in column G. The cell it reacts with is in Column H.

When it comes to this code.....
VBA Code: 
Private Sub MDList_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
         
    Select Case KeyCode
        Case 9 'Tab
           If MDList.Value <> "Not Listed" Then
             ActiveCell.Offset(0, 1).ClearContents
             ActiveCell.Offset(0, 1).Locked = True
            Else
             'If MDList.Value = "Not Listed" Then
             ActiveCell.Offset(0, 1).Locked = False
           End If
             ActiveCell.Offset(0, 1).Activate
             MDList.Visible = False
     End Select
End Sub

All cases work perfectly on the Keyboard. Tab works, Enter works, Left and right arrows work. When it comes to using the mouse.
VBA Code: 
Case 1 'Left Mouse click
           If MDList.Value <> "Not Listed" Then
             ActiveCell.Offset(0, 1).ClearContents
             ActiveCell.Offset(0, 1).Locked = True
            Else
             'If MDList.Value = "Not Listed" Then
             ActiveCell.Offset(0, 1).Locked = False
           End If
             ActiveCell.Offset(0, 1).Activate
             MDList.Visible = False
     End Select

This does not work. I even tried a separate sub using KeyUp for the mouse click. No Luck.
I cannot figure this out. I hope the folks here can.
Thank you in advance,
Jim
 
Sort by date Sort by votes
Try replacing "Private Sub MDList_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)" with this:

VBA Code: 
Private Sub MDList_Click()
    
    If MDList.ListIndex > -1 Then
            If MDList.Value <> "Not Listed" Then
             ActiveCell.Offset(0, 1).ClearContents
             ActiveCell.Offset(0, 1).Locked = True
            Else
             ActiveCell.Offset(0, 1).Locked = False
            End If
             ActiveCell.Offset(0, 1).Activate
             MDList.Visible = False
    End If

End Sub
 
Upvote 0

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
Hi Akuini,
I must be doing something wrong. Maybe I put the code in the wrong place on the sheet code. This gives me problems.

Sometimes if I click on the scroll bar in the ComboBox to make a choice, it crashes excel and closes the program. This problem is intermittent.

The other problem is, when I do make a final selection from the list with the mouse, It runs this line of code.

VBA Code: 
If Cells(y.Row, "R").Value <> "" Then Copyemail 'R

This line of code should ONLY run after the user selects Yes in a Msgbox after an entry in column N.
 
Upvote 0
Sorry Akuini,
I should have posted the entire code for your reference. Here it is.
VBA Code: 
'Variable for previous cell value
Dim old

'Code for single cell selection
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    If Selection.Cells.CountLarge > 1 Then
        MsgBox "Sorry, multiple selections are not allowed.", vbCritical
        ActiveCell.Select
    End If
    
'Code to retain previous cell values
    If Target.Cells.CountLarge = 1 Then
        If Not Intersect(Target, Range("A1:M1048576, O1:XFD1048576")) Is Nothing Then
          old = Target.Value
        End If
    End If

'Code for ComboBox
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Dim wsList As Worksheet
Dim nm As Name
Dim wsNm As Worksheet
Dim rng As Range
Set wsList = Sheets("List")

Set ws = ActiveSheet
  On Error GoTo errHandler

If Target.Count > 1 Then GoTo exitHandler

  Set cboTemp = ws.OLEObjects("MDList")
    On Error Resume Next
  If cboTemp.Visible = True Then
    With cboTemp
      .Top = 10
      .Left = 10
      .ListFillRange = ""
      .LinkedCell = ""
      .Visible = False
      .Value = ""
    End With
  End If

  On Error GoTo errHandler
  If Not Intersect(Target, Range("G6:G3000")) Is Nothing Then
    Application.EnableEvents = False
    str = Target.Validation.Formula1
    str = Right(str, Len(str) - 1)
    With cboTemp
      .Visible = True
      .Left = Target.Left
      .Top = Target.Top
      .Width = Target.Width + 30
      .Height = Target.Height + 15
      .ListFillRange = str
      If .ListFillRange <> str Then
        'for dynamic named ranges
        str = Target.Validation.Formula1
        str = Right(str, Len(str) - 1)
        Set wb = ActiveWorkbook
        Set nm = wb.Names(str)
        Set wsNm = wb.Worksheets _
          (nm.RefersToRange.Parent.Name)
        Set rng = wsNm.Range _
          (nm.RefersToRange.Address)
        .ListFillRange = "'" & wsNm.Name _
              & "'!" & rng.Address
      End If
      .LinkedCell = Target.Address
    End With
    cboTemp.Activate
  End If
exitHandler:
  Application.EnableEvents = True
  Application.ScreenUpdating = True
  Exit Sub
errHandler:
  Resume exitHandler
  
End Sub

'Keycode codes
Private Sub MDList_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
         
Select Case KeyCode
        Case 9 'Tab
            If MDList.Value <> "Not Listed" Then
             ActiveCell.Offset(0, 1).ClearContents
             ActiveCell.Offset(0, 1).Locked = True
            Else
             'If MDList.Value = "Not Listed" Then
             ActiveCell.Offset(0, 1).Locked = False
            End If
             ActiveCell.Offset(0, 1).Activate
             MDList.Visible = False
    'Select Case KeyCode
        Case 37 'Lt Arrow
            If MDList.Value <> "Not Listed" Then
             ActiveCell.Offset(0, 1).ClearContents
             ActiveCell.Offset(0, 1).Locked = True
            Else
             'If MDList.Value = "Not Listed" Then
             ActiveCell.Offset(0, 1).Locked = False
            End If
             ActiveCell.Offset(0, 1).Activate
             MDList.Visible = False
    'Select Case KeyCode
        Case 39 'Rt Arrow
            If MDList.Value <> "Not Listed" Then
             ActiveCell.Offset(0, 1).ClearContents
             ActiveCell.Offset(0, 1).Locked = True
            Else
             'If MDList.Value = "Not Listed" Then
             ActiveCell.Offset(0, 1).Locked = False
            End If
             ActiveCell.Offset(0, 1).Activate
             MDList.Visible = False
        Case 13 'Enter
            If MDList.Value <> "Not Listed" Then
             ActiveCell.Offset(0, 1).ClearContents
             ActiveCell.Offset(0, 1).Locked = True
            Else
             ActiveCell.Offset(0, 1).Locked = False
            End If
             ActiveCell.Offset(0, 1).Activate
             MDList.Visible = False
          End Select
End Sub

'Your code. Is it in the wrong place? What did I do wrong?
Private Sub MDList_Click()
    
    If MDList.ListIndex > -1 Then
            If MDList.Value = "Not Listed" Then
             ActiveCell.Offset(0, 1).Locked = False
            Else
             ActiveCell.Offset(0, 1).ClearContents
             ActiveCell.Offset(0, 1).Locked = True
            End If
             ActiveCell.Offset(0, 1).Activate
             MDList.Visible = False
    End If

End Sub

'Button 1
Private Sub CommandButton1_Click()
    UpdateDataFromMasterFile
End Sub

'Button 2
Private Sub CommandButton2_Click()
maint_form.Show
End Sub

'Cell lock / unlock code
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim r As Range, c As Range
  Set r = Union(Range("I6:J3000"), Range("K6:K3000"))
  Set r = Intersect(Target, r)
  If Not r Is Nothing Then
   Application.EnableEvents = False
   For Each c In r
    Select Case True
      Case 11 = c.Column 'K
        If c.Value = "" Then
          Cells(c.Row, "L").Value = ""
          Cells(c.Row, "L").Locked = True
          Else
          Cells(c.Row, "L").Locked = False
        End If
        Case 9 = c.Column 'I
        If c.Value = "" Then
          Cells(c.Row, "N").Value = ""
          Cells(c.Row, "N").Locked = True
          Else
          Cells(c.Row, "N").Locked = False
        End If
      Case Else
    End Select
  Next c
  End If
  
'Automatic Date code
  If Target.Cells.Count > 3 Then Exit Sub
   If Not Intersect(Target, Range("C6:C3000")) Is Nothing Then
    With Target(1, 3)
     .Value = Date
     .EntireColumn.AutoFit
    End With
  End If
    
'Row complete. Lock row and unlock next row.
     Dim p As Range, z As Range
     Set p = Range("N6:N2999")
     Set p = Intersect(Target, p)
     If Not p Is Nothing Then
   Application.EnableEvents = False
     For Each z In p
      Select Case True
       Case 14 = z.Column 'N
        If z.Value <> "" Then
         Check = MsgBox("Are your entries correct?" & vbCrLf & "After entering yes, These values CANNOT be changed.", vbYesNo + vbQuestion, "Cell Lock Notification")
            If Check = vbYes Then
             Target.Rows.EntireRow.Locked = True
             Cells(z.Row + 1, "B").Locked = False
             Cells(z.Row + 1, "C").Locked = False
             Cells(z.Row + 1, "D").Locked = False
             Cells(z.Row + 1, "E").Locked = False
             Cells(z.Row + 1, "F").Locked = False
             Cells(z.Row + 1, "G").Locked = False
             Cells(z.Row + 1, "H").Locked = False
             Cells(z.Row + 1, "I").Locked = False
             Cells(z.Row + 1, "J").Locked = False
             Cells(z.Row + 1, "K").Locked = False
             Cells(z.Row + 1, "M").Locked = False
             If Cells(z.Row, "R").Value <> "" Then Copyemail 'R
             If Cells(z.Row, "S").Value <> "" Then ThisWorkbook.Save 'S
             With Me
                .Parent.Activate
                .Activate
                .Range("B" & Rows.Count).End(xlUp).Offset(1).Activate
            End With
            Else
             Cells(z.Row, "N").Value = ""
           End If
          End If
      Case Else
    End Select
   Next z
 End If
 
'Row complete.  Sheet full.  Close and lock sheet.  Unlock and open next sheet.
 Dim e As Range, y As Range
    Set e = Range("N3000")
    Set e = Intersect(Target, e)
    If Not e Is Nothing Then
   Application.EnableEvents = False
     For Each y In e
      Select Case True
       Case 14 = y.Column 'N
        If y.Value <> "" Then
         Check = MsgBox("Are your entries correct?" & vbCrLf & "After entering yes, These values CANNOT be changed.", vbYesNo + vbQuestion, "Cell Lock Notification")
           If Check = vbYes Then
             Target.Rows.EntireRow.Locked = True
             Cells(y.Row + 1, "D").Value = "Book Closed"
             Sheets("Book 1").Range("A1:XFD1048576").Locked = True

       'This is the line of code that activates after a selection in the ComboBox.
             If Cells(y.Row, "R").Value <> "" Then Copyemail 'R

             If Cells(y.Row, "S").Value <> "" Then ThisWorkbook.Save 'S
             Sheets("Book 2").Range("B6:G6,I6:K6,M6").Locked = False
             Sheets("Book 2").Select
             Else
             Cells(y.Row, "N").Value = ""
           End If
        End If
      Case Else
    End Select
   Next y
 End If
 
'Administrator Close and lock sheet. Unlock and open next sheet.
 If Target.Cells.Count > 1 Then
  End If
    If Not Intersect(Target, Range("D3001")) Is Nothing Then
      If Target.Value <> "" Then
        With Application
          Sheets("Book 1").Range("A1:XFD1048576").Locked = True
          Sheets("Book 2").Range("B6:G6,I6:K6,M6").Locked = False
          Sheets("Book 2").Select
        End With
      End If
 End If

  'Cell change backup and send e-mail code.
  If Target.CountLarge > 1 Then
    End If
    If Not Intersect(Target, Range("B6:M1048576, O6:XFD1048576")) Is Nothing Then
      If Target.Locked = True Then
          With Application
           .EnableEvents = False
            With ThisWorkbook.Worksheets("Sheet2").UsedRange.Rows
            Sheets("Sheet2").Unprotect "Password"
             .Item(.Count + 1).Columns("B").Value = old
             .Item(.Count + 1).Columns("C").Value = Target.Value
             .Item(.Count + 1).Columns("D").Value = Environ("username")
             .Item(.Count + 1).Columns("E").Value = Now
             .Item(.Count + 1).Columns("F").Value = Target.Row
             .Item(.Count + 1).Columns("G").Value = Target.Column
              .Item(.Count + 1).Columns("H").Value = ActiveSheet.Name
            End With
                Application.ScreenUpdating = False
                Dim outlookApp As Object
                Dim myMail As Object
                Set outlookApp = CreateObject("Outlook.Application")
                Set myMail = outlookApp.CreateItem(0)
                myMail.To = "Me@company.net"
                myMail.Subject = "Changes made"
                myMail.HTMLBody = "Changes to file " & Application.ActiveWorkbook.FullName & ", " & ActiveSheet.Name & ",    Row " & Target.Row & ",    Column " & Target.Column
                myMail.send
             .EnableEvents = True
          End With
      End If
    End If
       Sheets("Sheet2").Protect "Password"
     Application.EnableEvents = True
End Sub

I hope this helps.

Jim
 
Upvote 0
Could you upload a sample workbook (without sensitive data) to a sharing site like dropbox.com or google drive?
And then share the link here.
 
Upvote 0
You must log in or register to reply here.

Similar threads

X
  • Question Question
Locking/unlocking a cell with a Combo Box value Mouse click problem
Replies
0
Views
770
XrayLemi
X
M
  • Question Question
Not running code
Replies
0
Views
218
MagicCarpet
M
M
  • Question Question
Using VBA code in a protected excel sheet
Replies
2
Views
546
MagicCarpet
M
D
  • Question Question
why show the frame of userform as the photo1
Replies
0
Views
210
david2005wang
D
M
  • Question Question
VBA - Find first empty cell in a row
Replies
2
Views
588
Mplz
M

Forum statistics

Threads
1,224,818
Messages
6,181,151
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top