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

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

很遗憾，迄今为止还没有被发明出来，因为这样的滚动条可以dynamic观察其他公式和图表发生了什么。

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

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

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

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

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

更新，2015年3月23日
以下是一些关于提高我的工具性能的跟进build议

Answer 1

在这个解决scheme中， Workbook和ScrollBar绑定在一起，形成一个ScrollValue类。 在Workbook_Open事件处理程序中创build此类的实例。

 ' ------------------------------------ ' 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类的instancing属性设置为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的行动： youtubevideo

Answer 2

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

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

所以第三个解决scheme是使用一个用户窗体。 这种方法的一个优点是，你可以添加其他控件，例如一个button，将单元格的值重置为其原始值。 这个解决scheme如下所述。

用一个滚动条和一个看起来像这样的button创build一个用户表单MagicScrollBar：

滚动条必须具有这些滚动属性：

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

 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 

最后在Module中复制这段代码（注意最复杂的部分是将像素中的鼠标坐标转换为点/英寸的用户forms坐标，我使用这里的代码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 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机器上，无法为您做任何确切的debugging，而且我也无法访问您的文件和确切的结构。 首先，帮助文件很难导航，但您可以在那里find大部分内容（在“对象成员”下面查看）。 我会警告你，形状和控件的对象层次结构是verrrry finicky。 我build议大量的debuggingtesting，并阅读文档中的对象成员。

为了让你知道，我的位置代码的逻辑是基于：

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

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

我之前做过这样的项目，所以应该可以工作，但是一如既往，请自行validation。 你可能需要一些int来加倍转换，你需要明确地强制转换以获得代码的位置部分（vba中不常见，但是当运行时引擎猜错时会发生这种情况）。 如果您以前没有使用过，请参阅帮助文件中的CInt（），CLng，CDbl（）等。

希望这一切都有帮助。 让我们知道是否有什么不工作。

Answer 4

这是完整的工具

你可以在这里下载scrollbar.xlsm文件：

我发布这个问题已经两年了。 我想出了以下解决scheme，我想与您分享。 在开始对这个问题进行奖励之前，我还没有分享这个问题，以获得新的解决问题的新概念。 根据我的经验，用鼠标更改单元格值的function比表格中的复杂模型和计算更能引起观众更多的印象:-)

把这个代码放在你想要显示scollb的工作表中。 您的工作表的名称并不重要。 右键单击工作表的名称，然后单击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 AG are used, othre columns can be used for something else ' Do not change the layout of AG columns unless you want to modify the code ' Addresses in Param have to be with dollars (ie $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 ie 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表格中的单元格来欣赏滚动条。

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

因为我认为提议的解决scheme不完整，所以我没有奖励任何人（2015年2月13日，星期五）的赏金。 我想感谢两位贡献者Philippe.H和Dee的回答。 我喜欢Philippe.H的第一次尝试，它简单而快速，但缺乏dynamic（希望你可以重新发布）。

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

Answer 5

我认为最简单的解决scheme是使用列表内嵌下拉列表以编程方式分配数据validation。 因此，在工作簿中，您将拥有一个SourceDropDown表。

这里是我会有的步骤：

1. 确保你想要下拉的所有单元格都是命名的范围。 如果您决定插入/删除行，这将是非常宝贵的。
2. 创build一个包含列表的所有值的工作表
3. 使用工作表更改事件来确保在复制和粘贴的情况下validation不会被覆盖

以下是一个示例代码，让你开始。

 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