用鼠标增加改变Excell单元格的速度

我想增加改变Excel单元格的值只用鼠标的速度。 我分享我的工具，希望有人会喜欢它，并希望改善它。

这是一个例子。 单击包含值的定义单元格后，滚动条出现在单元格的右侧。 你可以用鼠标平滑地改变它的值。

该工具旨在更改单元格值并dynamic观察公式值。 您可以简化代码，但不应禁用某些function。 它应该始终保持dynamic，即移动的滚动条应立即影响其他单元格的公式。 滚动条不应该闪烁（改变颜色灰色和黑色）。

您可以直接在这里下载scrollbar.xlsm文件并查看其中的VBA代码。

或者你可以把这个代码放在你想要的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, SearchCell 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(SearchCell) 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(SearchCell)) 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 1

我更喜欢：

 Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Intersect(Target, Range("A1:A10")) Is Nothing Then Exit Sub If OLEObjects.Count = 0 Then OLEObjects.Add "Forms.ScrollBar.1", , , , , , , Target.Offset(, 1).Left, Target.Top, 199, 15 With OLEObjects(1) .Top = Target.Top .object.max=200 Target = Application.Max(Target, .Object.Min) Target = Application.Min(Target, .Object.Max) .LinkedCell = Target.Address End With End Sub 

Answer 2

点击左/右箭头或滚动条内部时，要改变数值，我宁愿添加：

 Private Sub scrlSh_Change() If ActiveSheet.OLEObjects(scrlName).LinkedCell <> "" Then scrlSh_Scroll End If End Sub 

我更喜欢使用types化的函数，如UCase$ ， Left$ ，…而不是它们的变体等价物（ UCase ， Left ，…），但是对于这个macros，真正的性能并不是真正需要的。

在你的Worksheet_SelectionChange子文件中，我用原始值代替了actSheet ， SheetFly和adrvariables（因为只有一次）。 没有真正的大改进呢。