Home » excel » vba – How to change Excel cell's value with a mouse only?

vba – How to change Excel cell's value with a mouse only?

Posted by: admin March 9, 2020 Leave a comment

Questions:

I would like to be able to easily change cells value (constants, not formulas) with a mouse only, without typing new value with a keyboard.

Such a scrollbar would allow users to observe dynamically what happens with other formulas and charts.

After clicking on a cell which contains a value, some scrollbar (or other device) shows up below the cell (or right to the cell). It would be possible to change the value of the cell with mouse only using this device. It should be possible to define the min and max values of the scrollbar. If not defined the min and max values should be assumed as i.e. 30% (min) and 170% (max) of the current value. When clicking on another cell the “old” scrollbar disappears and a new one shows up below the clicked cell. There should be a possibility to define cell for which scrollbar shows up (for other cells it would not).

I need something else than ordinary Excel scrollbar which changes ONLY ONE cell’s value and I do not want to have hundred of scrollbars scattered all over my sheet.

From my research I found out that I can set up events in the worksheet or workbook that will respond to a cell being selected. I can check whether that cell is one that is allowed to display the scrollbar. If so, I can have my code either create a new scrollbar, or make an existing one visible, and locate the scrollbar below the active cell. Changing the scrollbar could affect the cell’s value. Some control over how the value changes is needed, to avoid values with 15 decimal digits. When the cell is deselected, the scrollbar can be destroyed, or hidden until its next use.

Update

I have submitted an answer to my question. Now I look forward to improving the speed of my tool.

Update 2

Here are some follow up proposals of improving the performance of my tool

How to&Answers:

In this solution the Workbook and ScrollBar are bound together into one class ScrollValue. In Workbook_Open event handler the instance of this class is created.

' ------------------------------------
' ThisWorkbook class module
' ------------------------------------
Option Explicit

Public ScrollValueWidget As ScrollValue

Private Sub Workbook_Open()
    Set ScrollValueWidget = New ScrollValue
    ScrollValueWidget.Max = 1000
    ScrollValueWidget.Min = 0
    ScrollValueWidget.Address = "C3:D10"
    ScrollValueWidget.DeleteScrollBars
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set ScrollValueWidget = Nothing
End Sub

ScrollValue class takes care of the ScrollBar and it handles SheetSelectionChange event for all the sheets in workbook in one place. After cell has changed the scroll bar is shown and linked to the changed cell. Scroll bar becomes min and max limits. Value of scroll bar is automatically set acording to target cell value. If the actual cell value exceeds the min-max range a warning is shown.

Scrollbars class uses a OLEObjects collection. For each sheet it has its own scroll bar. So for each sheet only one scroll bar exists at a time.

Note: the value of ScrollBars Value property can’t be negative. Set the instancing property of class ScrollValue to PublicNotCreatable.

' ------------------------------------
' ScrollValue class module
' ------------------------------------

Option Explicit

Private minValue As Long
Private maxValue As Long
Private applyToAddress As String
Private WithEvents book As Workbook
Private scroll As OLEObject
Private scrolls As ScrollBars

Private Sub Class_Initialize()
    Set book = ThisWorkbook
    Set scrolls = New ScrollBars
End Sub

Private Sub Class_Terminate()
    Set scrolls = Nothing
    Set book = Nothing
End Sub

Private Sub book_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    On Error GoTo ErrSheetSelectionChange

    Set scroll = scrolls.GetOrCreate(Sh) ' Get scroll for targer sheet
    Move Target ' Move scroll to new target cell

    Exit Sub

ErrSheetSelectionChange:
    MsgBox Err.Description, vbCritical
End Sub

Private Sub Move(targetRange As Range)
    ' Do not handle scroll for cells with formulas, not numeric or negative values
    If targetRange.HasFormula Then _
        Exit Sub

    If Not IsNumeric(targetRange.Value) Then _
        Exit Sub

    If targetRange.Value < 0 Then _
        Exit Sub

    If Application.Intersect(targetRange, ApplyToRange(targetRange.Worksheet)) Is Nothing Then _
        Exit Sub

    ' TODO: add code to handle when min/max not defined

    On Error GoTo ErrMove

    ' Move scroll to new target cell and show it
    With scroll
        .Top = targetRange.Top
        .Left = targetRange.Left + targetRange.Width + 2
        .Object.Min = Min
        .Object.Max = Max
        .LinkedCell = targetRange.Address
        .Visible = True
    End With

    Exit Sub

ErrMove:
    Dim errMsg As String
    errMsg = "Max = " & Max & " Min = " & Min & " Cell value = " & targetRange.Value & " must be between <Min, Max>." & Err.Description
    MsgBox errMsg, vbExclamation, "Scroll failed to show"
End Sub

Public Property Get Min() As Long
    Min = minValue
End Property

Public Property Let Min(ByVal newMin As Long)
    If newMin < 0 Then _
        Err.Raise vbObjectError + 1, "ScrollValue", "Min value musn't be less then zero"
    If newMin > maxValue Then _
        Err.Raise vbObjectError + 2, "ScrollValue", "Min value musn't be greater then max value"
    minValue = newMin
End Property

Public Property Get Max() As Long
    Max = maxValue
End Property

Public Property Let Max(ByVal newMax As Long)
    If newMax < 0 Then _
        Err.Raise vbObjectError + 3, "ScrollValue", "Max value musn't be less then zero"
    If newMax < minValue Then _
        Err.Raise vbObjectError + 4, "ScrollValue", "Max value musn't be less then min value"
    maxValue = newMax
End Property

Public Property Let Address(ByVal newAdress As String)
    If newAdress = "" Then _
        Err.Raise vbObjectError + 5, "ScrollValue", "Range address musn't be empty string"
    applyToAddress = newAdress
End Property

Public Property Get Address() As String
    Address = applyToAddress
End Property

Private Property Get ApplyToRange(ByVal targetSheet As Worksheet) As Range
    ' defines cell(s) for which scrollbar shows up
    Set ApplyToRange = targetSheet.Range(Address)
End Property

Public Sub DeleteScrollBars()
    scrolls.DelateAll
End Sub

' ------------------------------------
' ScrollBars class module
' ------------------------------------

Option Explicit

Private Const scrollNamePrefix As String = "ScrollWidget"

Private Sub Class_Terminate()
    DelateAll
End Sub

Private Function ScrollNameBySheet(ByVal targetSheet As Worksheet) As String
    ScrollNameBySheet = scrollNamePrefix & targetSheet.name
End Function

Public Function GetOrCreate(ByVal targetSheet As Worksheet) As OLEObject
    Dim scroll As OLEObject
    Dim scrollName As String

    scrollName = ScrollNameBySheet(targetSheet)

    On Error Resume Next
    Set scroll = targetSheet.OLEObjects(scrollName)
    On Error GoTo 0

    If scroll Is Nothing Then
        Set scroll = targetSheet.OLEObjects.Add(ClassType:="Forms.ScrollBar.1", _
            Left:=0, Top:=0, Width:=250, Height:=16)
        scroll.name = scrollName
        scroll.AutoLoad = True
        scroll.Object.Orientation = fmOrientationHorizontal
        scroll.Object.BackColor = &H808080
        scroll.Object.ForeColor = &HFFFFFF
    End If

    scroll.Enabled = True
    scroll.Locked = False
    scroll.LinkedCell = ""
    scroll.Visible = False

    Set GetOrCreate = scroll
End Function

Public Sub DelateAll()
    ' Deletes all scroll bars on all sheets if its name beginns with scrollNamePrefix

    Dim scrollItem As OLEObject
    Dim Sh As Worksheet

    For Each Sh In Worksheets
        For Each scrollItem In Sh.OLEObjects
            If scrollItem.name Like scrollNamePrefix & "*" Then
                scrollItem.Locked = False
                scrollItem.delete
            End If
        Next scrollItem
    Next Sh
End Sub

enter image description here

Watch ScrollValue in action:
youtube video

Answer:

You need to use the Workbook_SheetSelectionChange event to catch the selection of a new cell. You must build some controls to be sure that scrollbar is displayed only when one cell is selected and not a range, that cell does not contain a formula, that the cell value is numeric. You need to think about how the value changes when baseValue = 0 (as 30% of 0 is still 0).

For the scroll bar you can position it directly into the worksheet, using a Form control or an ActiveX control. The former is simpler to implement but with that solution the cell value will not update as you are scrolling. If you need this, you have to use the ActiveX control. But in that case, you have to generate event handlers dynamically with CreateEventProc. This solution comes with some heavy drawbacks as mentioned in the comments.

So a third solution is to use a userform. One advantage of this method is that you can add other controls onto it, e.g a button to reset the cell value to its original value. This solution is described below.

Create a userform with a scrollbar and a button that looks like this and name it MagicScrollBar:

enter image description here

The scrollbar must have these scrolling properties:

enter image description here

Right click the userform, Chose View code and copy this code:

Option Explicit

Private Sub CommandButton1_Click()
    ActiveCell.Value = baseValue
    ScrollBar1.Value = 100
End Sub

Private Sub ScrollBar1_Change()
    UpdateCellValue
End Sub

Private Sub ScrollBar1_scroll()
    UpdateCellValue
End Sub

Private Sub UpdateCellValue()
    ActiveCell.Value = baseValue * ScrollBar1.Value / 100
End Sub

Copy this code in ThisWorkbook:

Option Explicit

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

    Dim l As Double
    Dim t As Double
    Dim w As Double
    Dim h As Double

    MagicScrollBar.Hide

    If Selection.CountLarge = 1 Then
        If Not Intersect(Target, ActiveSheet.Cells) Is Nothing Then 'Replace ActiveSheet.Cells by range where scroll bar should appear
            If Target.HasFormula = False Then
                If IsNumeric(Target.Value) Then
                    If Target.Value <> 0 Then 'TO DO: Add some logic to handle cells with value = 0

                        baseValue = Target.Value

                         With MagicScrollBar
                            .ScrollBar1.Value = 100
                            .StartUpPosition = 0
                            .top = convertMouseToForm.top + Target.Height
                            .left = convertMouseToForm.left
                        End With

                        MagicScrollBar.Show vbModeless

                    End If
                End If
            End If
        End If
    End If

End Sub

Finally copy this code in Module (notice that the most complex part is to convert the mouse coordinates in pixels into userform coordinates in points/inch for which I used the code from here http://ramblings.mcpher.com/Home/excelquirks/snippets/mouseposition)

 Option Explicit

    Public baseValue As Double

    'Source: http://ramblings.mcpher.com/Home/excelquirks/snippets/mouseposition
    Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function GetDeviceCaps Lib "Gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long

    Const LOGPIXELSX = 88
    Const LOGPIXELSY = 90

    Public Type tCursor
        left As Long
        top As Long
    End Type

    Private Declare Function GetCursorPos Lib "user32" (p As tCursor) As Long

Public Function pointsPerPixelX() As Double
    Dim hDC As Long
    hDC = GetDC(0)
    pointsPerPixelX = 72 / GetDeviceCaps(hDC, LOGPIXELSX)
    ReleaseDC 0, hDC
End Function

Public Function pointsPerPixelY() As Double
    Dim hDC As Long
    hDC = GetDC(0)
    pointsPerPixelY = 72 / GetDeviceCaps(hDC, LOGPIXELSY)
    ReleaseDC 0, hDC
End Function

Public Function WhereIsTheMouseAt() As tCursor
    Dim mPos As tCursor
    GetCursorPos mPos
    WhereIsTheMouseAt = mPos
End Function

Public Function convertMouseToForm() As tCursor
    Dim mPos As tCursor
    mPos = WhereIsTheMouseAt
    mPos.left = pointsPerPixelY * mPos.left
    mPos.top = pointsPerPixelX * mPos.top
    convertMouseToForm = mPos
End Function

Answer:

This is complete tool

You can download the scrollbar.xlsm file here:

It is two years after I posted the question. I have come up with the following solution. I have not shared it before in order to get fresh concepts of tackling the problem. In my experience the feature of changing cell value with a mouse arouse sometimes more impression on the audience than complex models and calculations in the sheet 🙂

Put this code in your sheet where you want the scrollbars to appear. The name of your sheet does not matter. Right click on the sheet’s name and then click View Code. This is the place:

enter image description here

Insert there this code:

Option Explicit
Dim previousRow, c
Const scrlName As String = "scrlSh" ' the name of the scrollbar


Private Sub scrlSh_GotFocus()
    ActiveSheet.Range(ActiveSheet.OLEObjects(scrlName).TopLeftCell.Offset(0, -1).Address).Activate
End Sub

Private Sub scrlSh_Scroll()
Dim rngCell As Range

Set rngCell = Sheets("Param").Range(ActiveSheet.OLEObjects(scrlName).LinkedCell)

    ActiveSheet.OLEObjects(scrlName).TopLeftCell.Offset(0, -1).Value = _
        rngCell.Offset(0, 1).Value + (ActiveSheet.OLEObjects(scrlName).Object.Value * rngCell.Offset(0, 3).Value)

Set rngCell = Nothing
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Macro concept by Przemyslaw Remin, VBA code written by Jaroslaw Smolinski
' The Sub Worksheet_SelectionChange and function SearchAdr have to be on each sheet where scrollbars are to appear
' Sheet Param is one for all sheets, only the columns A-G are used, othre columns can be used for something else
' Do not change the layout of A-G columns unless you want to modify the code
' Addresses in Param have to be with dollars (i.e. $A$3) or it may be named ranges of single cells
' (if it starts with $ it is a cell, otherwise it is a named range)
' the lower or upper case in addresses does not matter


Dim SheetFly As String, adr As String
Dim cCell As Range
Dim actSheet As Worksheet
Dim shScroll As Object

    Set actSheet = ActiveSheet

    ' checks if scrollbar exists
    If actSheet.Shapes.Count > 0 Then
        For Each shScroll In actSheet.Shapes
            If shScroll.Type = msoOLEControlObject And shScroll.Name = scrlName Then
                Exit For ' scrollbar found, and the variable is set
            End If
        Next shScroll
    End If
    ' if scrollbar does not exists then it is created
    If shScroll Is Nothing Then
        Set shScroll = ActiveSheet.OLEObjects.Add(ClassType:="Forms.ScrollBar.1", Link:=False, _
            DisplayAsIcon:=False, Left:=0, Top:=0, Width:=64 * 3, Height:=15)
            ' scrollbar length is set as three adjesent columns
        shScroll.Visible = False
        shScroll.Name = scrlName
        shScroll.Placement = xlMoveAndSize
    End If

    shScroll.Visible = False
    adr = Target.AddressLocal
    SheetFly = actSheet.Name


    ' here we set up in which cells the scrollbar has to appear. We set up only the number of rows
    Set cCell = SearchAdr(SheetFly, adr, Sheets("Param").Range("B2:B40")) ' If needed it can be longer i.e. B2:B400
    If Not cCell Is Nothing Then
        With ActiveSheet.OLEObjects(scrlName)
            .LinkedCell = "" ' temporary turn off of the link to the cell to avoid stange behaviour
            .Object.Min = 0 ' the scale begins from 0, not negative
            .Object.Max = Abs((cCell.Offset(0, 4).Value - cCell.Offset(0, 3).Value) / cCell.Offset(0, 5).Value)
            .Object.SmallChange = 10   ' single change by one step
            .Object.LargeChange = 10   ' change by jumps after clicking on scrollbar bar ("page up", "page down")
            If Target.Value <> cCell.Offset(0, 2).Value And Target.Value >= cCell.Offset(0, 3).Value And Target.Value <= cCell.Offset(0, 4).Value Then
                ' setting up the cells value as close as possible to the value of input by hand
                ' rounded by step
                ' if value is out of defined range then the last value will be used
                cCell.Offset(0, 2).Value = Abs((Target.Value - cCell.Offset(0, 3).Value) / cCell.Offset(0, 5).Value)
            End If
            'Protection in case the value is out of min and max range
            If cCell.Offset(0, 2).Value > .Object.Max Then
                cCell.Offset(0, 2).Value = .Object.Max
            ElseIf cCell.Offset(0, 2).Value < .Object.Min Then
                cCell.Offset(0, 2).Value = .Object.Min
            End If
            Target.Value = cCell.Offset(0, 3).Value + (cCell.Offset(0, 5).Value * cCell.Offset(0, 2).Value)
            .Object.Value = cCell.Offset(0, 2).Value
            .LinkedCell = "Param!" & cCell.Offset(0, 2).Address 'setting up linked cell
        End With
        ' Setting up the position and width of scrollbar with reference to the cell
        shScroll.Top = Target.Top
        shScroll.Left = Target.Offset(0, 1).Left + 2 'position to the right + small margin
        shScroll.Width = Target.Offset(0, 5).Left - Target.Offset(0, 1).Left - 2 'width of 5 columns
        shScroll.Visible = True
    End If

    Set actSheet = Nothing
    Set shScroll = Nothing
    Set cCell = Nothing
End Sub

Private Function SearchAdr(SheetFly As String, kom As String, rng As Range) As Range
Dim cCell As Range
Dim oOOo As Name

' Searching for the row with parameter for chosen cell
' The parameter have to be in one, continouse range

For Each cCell In rng
    If cCell.Text = "" Then ' check if parameters have not finished
        Set SearchAdr = Nothing
        Exit Function ' stop if you find first empty cell for speeding
    ElseIf Left(cCell.Text, 1) = "$" Then ' normal address
        If cCell.Offset(0, 1).Text & "!" & UCase(cCell.Text) = SheetFly & "!" & UCase(kom) Then
            Set SearchAdr = cCell
            Exit Function   ' exit if find proper row with parameters
        End If
    Else ' means that found is a name
        For Each oOOo In ActiveWorkbook.Names
            If (oOOo.RefersTo = "=" & SheetFly & "!" & UCase(kom)) And (UCase(oOOo.Name) = UCase(cCell.Text)) Then
                Set SearchAdr = cCell
                Exit Function   ' exit if find proper row with parameters
            End If
        Next oOOo
    End If
Next cCell

End Function

In your workbook you have to make sheet named Param where the parameters of scrollbar are stored. In column A and C put the name of your sheet where you want scrollbars to appear. The sheet looks like this:

enter image description here

Now you can enjoy the scrollbar after clicking the cell in the model sheet.

enter image description here

Note that you can define different min, max ranges and step of scrollbar change separately for every cell. Moreover, the min and max range can be negative.

My solution is simple however I wished it could be further improved with respect to speed. With complex calculations within the workbook the performance of scrollbar might be better.

Answer:

I’m not totally sure of your requirements, but it sounds to me like you are right to try

Worksheet_SelectionChange(ByVal Target As Range)

Again, I am not sure of the logic requirements for which cells are allowed scroll bars, but judging by your question, you already understand that for yourself. So what I would do to get the scroll bar underneath the selected cell is something like:

Set oYourScrollBar = ActiveSheet.Shapes("YourScrollBar")

If isSrollBarCell Then  'It is assumed you figured this part out!

  oYourScrollBar.Visible = True  'You may want to get rid of ScreenUpdating first for stylistic reasons.

  oYourScrollBar.Top = Target.Top + Target.Height  'Vert Distance to clicked cell + Height of clicked cell puts you under the cell
  oYourScrollBar.Left = Target.Left + (Target.Width - oYourScrollBar.Width) / 2  'Follow that one?

  oYourScrollBar.ControlFormat.LinkedCell = target.Address  'Change the linked cell of the scroll bar

Else

  oYourScrollBar.Visible = False  'Since there is no scrolling here, hide the scroll bar

End If

I want to caution that this code was written by referencing the MSDN online documentation. I am on a Linux machine right now and cannot do any exact debugging for you, and I don’t have access to your file and exact structure. The help files are tough to navigate at first, but you can find most everything there (check under the “object members”). I will warn you that the Shapes and Controls object hierarchies are verrrry finicky. I recommend a lot of debug testing and reading the object members in the documentation.

To let you know, my logic for the location code was based on:

Top (distance from top edge of file) – the distance to the clicked cell (target) + the height of the clicked cell puts you at the bottom of the clicked cell.

Left (distance from left edge of the file) – the distance to the clicked cell (target) plus half the width of the clicked cell puts the edge of the scroll bar in the centerline of target. Subtracting half the width of the scroll bar puts the centerline of the scroll bar on the centerline of target. This accounts for the scroll bar and cell being different sizes.

I have done projects like this before, so it should work, but as always, verify it yourself. You may have some int to double conversions that you need to explicitly cast to get the position part of the code to run right (not common in vba, but it happens when the runtime engine guesses wrong). If you haven’t used these before, see CInt(), CLng, CDbl(), etc in the help files.

Hope all this helps. Let us know if something did not work.

Answer:

I think the simplest solution would be to programmatically assign a data validation using a list with in-cell drop-down. So in workbook you will have a SourceDropDown sheet.

Here are the steps I would have:

  1. Ensure that all cells you want to have drop-downs for are named ranges. This would be invaluable if you ever decide to insert/delete rows.
  2. Create a worksheet with all the values for your list
  3. Use the Worksheet Change event to ensure validation is never overwritten in the event of copying and pasting

The following is a sample code to get you started.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell As Range
    Set cell = ThisWorkbook.Worksheets(1).Range("MyNamedRange") ' change to whatever you have
    If Not Application.Intersect(cell, Range(Target.Address)) Is Nothing Then
        With cell.Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:="=SourceDropDown!$T$2:$T$20"
            .ShowError = False
        End With
    End If
End Sub