Question

我希望能够轻松地仅使用鼠标更改单元格值（常量，而不是公式），而无需使用键盘键入新值。

令人遗憾的是，到目前为止还没有发明它，因为这样的滚动条允许动态观察其他公式和图表会发生什么。

单击包含值的单元格后，某些滚动条（或其他魔鬼设备）会显示在单元格下方（或单元格右侧）。只使用此设备可以用鼠标更改单元格的值。应该可以定义滚动条的最小值和最大值。如果未定义，则应将最小值和最大值假定为当前值的30％（min）和170％（max）。单击另一个单元格时，“旧”滚动条将消失，并且新单击滚动条将显示在单击的单元格下方。应该有可能定义滚动条显示的单元格（对于其他单元格，它不会）。

我需要的东西不是普通的Excel滚动条，它只会改变一个单元格的值，而且我不希望在我的工作表上分散有数百个滚动条。

从我的研究中我发现：
我可以在工作表或工作簿中设置将响应所选单元格的事件。我可以检查该单元格是否允许显示滚动条。如果是这样，我可以让我的代码创建一个新的滚动条，或使现有的滚动条可见，并找到活动单元格下方的滚动条。更改滚动条可能会影响单元格的值。需要控制值如何更改，以避免使用15位十进制数字的值。取消选择单元格后，可以销毁或隐藏滚动条，直到下次使用。

由于我是VBA的中级用户，有人可以指导我吗？也许有人之前构建过类似的设备？

更新，2015年2月13日
我已经提交了我的问题的答案。现在我期待着提高工具的速度。

更新，2015年3月23日
Here are some follow up proposals of improving the performance of my tool

Answer 1

在此解决方案中，Workbook和ScrollBar被绑定到一个类ScrollValue中。在Workbook_Open事件处理程序中，创建了此类的实例。

' ------------------------------------
' 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班负责处理ScrollBar，并在一个位置处理工作簿中所有工作表的SheetSelectionChange事件。单元格更改后，将显示滚动条并链接到更改的单元格。滚动条变为最小和最大限制。滚动条的值根据目标单元格值自动设置。如果实际单元格值超出最小 - 最大范围，则会显示警告。

Scrollbars类使用OLEObjects集合。对于每张纸，它都有自己的滚动条。因此，对于每张工作表，一次只存在一个滚动条。

注意：ScrollBars Value属性的值不能为负数。将类ScrollValue的实例化属性设置为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

观看ScrollValue： youtube video

Answer 2

您需要使用Workbook_SheetSelectionChange事件来捕获新单元格的选择。您必须构建一些控件以确保仅在选择一个单元格而不是范围（该单元格不包含公式）时才显示滚动条，单元格值为数字。你需要考虑当baseValue = 0时值的变化（0的30％仍为0）。

对于滚动条，您可以使用Form控件或ActiveX控件将其直接放置到工作表中。前者更容易实现，但使用该解决方案时，单元格值不会随着您的滚动而更新。如果需要，则必须使用ActiveX控件。但在这种情况下，您必须使用CreateEventProc动态生成事件处理程序。这个解决方案带有一些重要的缺点，如评论中所述。

所以第三种解决方案是使用userform。此方法的一个优点是您可以在其上添加其他控件，例如用于将单元格值重置为其原始值的按钮。该解决方案如下所述。

使用滚动条和一个如下所示的按钮创建一个userform，并将其命名为MagicScrollBar：

enter image description here

滚动条必须具有以下滚动属性：

enter image description here

右键单击userform，选择查看代码并复制此代码：

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

在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

最后在模块中复制此代码（请注意，最复杂的部分是将鼠标坐标以像素为单位转换为用户形态坐标，以点/英寸为单位，我使用此处的代码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 3

我不完全确定你的要求，但听起来我觉得你是正确的尝试

Worksheet_SelectionChange(ByVal Target As Range)

同样，我不确定哪些单元格允许使用滚动条的逻辑要求，但根据您的问题判断，您已经了解了这一点。那么我要做的是让所选单元格下方的滚动条如下：

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

我想提醒一下，此代码是通过引用MSDN在线文档编写的。我现在在Linux机器上，无法为您做任何准确的调试，我无法访问您的文件和确切的结构。帮助文件一开始很难导航，但您可以在那里找到大部分内容（请在“对象成员”下查看）。我会警告你，Shapes和Controls对象层次结构是错误的。我建议大量的调试测试和阅读文档中的对象成员。

为了通知您，我的位置代码逻辑基于：

顶部（距文件上边缘的距离） - 点击的单元格（目标）的距离+单击的单元格的高度使您处于单击的单元格的底部。

左（距文件左边缘的距离） - 单击单元格（目标）的距离加上单击单元格宽度的一半将滚动条的边缘放在目标的中心线上。减去滚动条宽度的一半会使滚动条的中心线位于目标的中心线上。这说明滚动条和单元格大小不同。

我以前做过这样的项目，所以它应该可以工作，但一如既往，请自行验证。您可能需要显式转换一些int到double的转换，以使代码的位置部分正常运行（在vba中不常见，但它会在运行时引擎猜错时发生）。如果您之前没有使用过它们，请参阅帮助文件中的CInt（），CLng，CDbl（）等。

希望这一切都有所帮助。如果有什么不起作用，请告诉我们。

Answer 4

这是完整的工具

您可以下载 scrollbar.xlsm 文件here：

我发布问题后2年。我想出了以下想要与您分享的解决方案。在开始对问题的赏金之前，我还没有分享它，以获得解决问题的新概念。根据我的经验，用鼠标改变单元格值的功能有时会引起观众的印象比复杂的模型和表格中的计算:-)

将此代码放在您希望显示scollbars的工作表中。工作表的名称无关紧要。右键单击工作表的名称，然后单击View Code。这是地方：

enter image description here

插入此代码：

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

在工作簿中，您必须创建名为Param的工作表，其中存储了滚动条的参数。在A列和C列中，将工作表的名称放在要显示滚动条的位置。表格如下：

enter image description here

现在，您可以在点击model表单中的单元格后欣赏滚动条。

enter image description here

请注意，您可以为每个单元格分别定义不同的最小值，最大值范围和滚动条更改步骤。此外，最小和最大范围可能是负的。

由于我认为提议的解决方案不完整，我不会向任何人（2015年2月13日星期五）奖励赏金。我要感谢两位贡献者 Philippe.H 和 dee 的答案。我喜欢 Philippe.H 的第一次尝试，它很简单，但工作速度快但缺乏动力（希望你能重新发布）。

我的解决方案很简单，但我希望在速度方面可以进一步改进。通过工作簿中的复杂计算，滚动条的性能可能会更好。也许有人请改善搜索条件以加快搜索速度。希望，你可以帮忙。

Answer 5

我认为最简单的解决方案是使用带有单元格下拉列表的列表以编程方式分配数据验证。因此，在工作簿中，您将获得SourceDropDown表。

以下是我的步骤：

确保您想要具有下拉列表的所有单元格都是命名范围。如果您决定插入/删除行，这将是非常宝贵的。
创建包含列表所有值的工作表
使用工作表更改事件确保在复制和粘贴时不会覆盖验证

以下是帮助您入门的示例代码。

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

如何仅使用鼠标更改Excel单元格的值？

5 个答案: