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

Question

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

这样的滚动条将允许用户动态观察其他公式和图表发生的情况。

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

我需要的不是普通的 Excel 滚动条，它只改变一个单元格的值，我不想让数百个滚动条分散在我的工作表上。

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

更新

我已经提交了我的问题的答案。现在我期待着提高我的工具的速度。

更新 2

以下是一些改进我的工具性能的后续建议

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

观看 ScrollValue 的实际操作： youtube 视频

Answer 2

这是完整的工具

您可以在此处下载scrollbar.xlsm文件：

我发布这个问题已经两年了。我想出了以下解决方案。为了获得解决问题的新概念，我以前没有分享过它。以我的经验，用鼠标改变单元格值的功能有时比表格中的复杂模型和计算更能引起观众的印象:-)

将此代码放在您希望滚动条出现的工作表中。工作表的名称无关紧要。右键单击工作表的名称，然后单击View 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

在您的工作簿中，您必须将工作表命名Param为存储滚动条参数的位置。在 A 列和 C 列中，将工作表的名称放在您希望滚动条出现的位置。工作表如下所示：

现在，您可以在单击工作表中的单元格后享受滚动条model。

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

我的解决方案很简单，但我希望它可以在速度方面得到进一步改进。在工作簿中进行复杂计算时，滚动条的性能可能会更好。

Answer 3

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

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

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

创建一个带有滚动条和按钮的用户窗体，如下所示，并将其命名为 MagicScrollBar：

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

右键单击用户窗体，选择查看代码并复制此代码：

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/片段/鼠标位置）

 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 4

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

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 5

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

以下是我将采取的步骤：

1. 确保要为其设置下拉菜单的所有单元格都是命名范围。如果您决定插入/删除行，这将是非常宝贵的。
2. 创建一个包含列表所有值的工作表
3. 使用 Worksheet Change 事件确保在复制和粘贴时不会覆盖验证

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

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