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

Question

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

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

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

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

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

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

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

更新,2015年3月23日
以下是一些提高工具性能的后续建议

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

ScrollValueclass负责ScrollBar处理并SheetSelectionChange在一个地方处理工作簿中所有工作表的事件.单元格更改后,将显示滚动条并链接到更改的单元格.滚动条变为最小和最大限制.滚动条的值根据目标单元格值自动设置.如果实际单元格值超过最小 - 最大范围,则会显示警告.

Scrollbarsclass使用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

观看ScrollValue的实际操作: youtube video

Answer 2

我不完全确定你的要求，但在我看来你尝试是正确的

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 机器上，无法为您进行任何精确的调试，并且我无权访问您的文件和确切的结构。帮助文件一开始很难浏览，但您可以在那里找到几乎所有内容（在“对象成员”下检查）。我会警告您，形状和控件对象层次结构非常挑剔。我建议进行大量调试测试并阅读文档中的对象成员。

让您知道，我的位置代码逻辑基于：

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

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

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

希望这一切有帮助。如果出现问题请告诉我们。