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.
I have submitted an answer to my question. Now I look forward to improving the speed of my tool.
In this solution the
ScrollBar are bound together into one class
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 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
Watch ScrollValue in action:
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:
The scrollbar must have these scrolling properties:
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
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:
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:
Now you can enjoy the scrollbar after clicking the cell in the
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.
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.
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
Here are the steps I would have:
- 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.
- Create a worksheet with all the values for your list
- 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