新しいセルの選択をキャッチするには、Workbook_SheetSelectionChange イベントを使用する必要があります。範囲ではなく 1 つのセルが選択されている場合にのみスクロールバーが表示されること、そのセルに数式が含まれていないこと、セルの値が数値であることを確認するために、いくつかのコントロールを構築する必要があります。baseValue = 0 の場合に値がどのように変化するかを考える必要があります (0 の 30% は 0 のままです)。
スクロール バーについては、フォーム コントロールまたは ActiveX コントロールを使用して、ワークシートに直接配置できます。前者は実装が簡単ですが、そのソリューションでは、スクロール中にセルの値が更新されません。これが必要な場合は、ActiveX コントロールを使用する必要があります。ただし、その場合は、CreateEventProc を使用して動的にイベント ハンドラーを生成する必要があります。コメントに記載されているように、このソリューションにはいくつかの重大な欠点があります。
したがって、3 番目の解決策は、ユーザーフォームを使用することです。この方法の利点の 1 つは、セルの値を元の値にリセットするボタンなど、他のコントロールを追加できることです。このソリューションについては、以下で説明します。
次のようなスクロールバーとボタンを含むユーザーフォームを作成し、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
