VBA初心者です。任意のセルの自動計算をしたいのですが・・・

質問

自動マクロを使い作成していましたが、煮詰まりました。お知恵をいただきたくお願い致します。
シートの各セルの中に整数が入っているとします。（仮にシート一面に全て）
エクセルの任意のセル（その都度列、行とも違う）に対して、87％（切捨て）を掛けた金額を出したいと思います。
出来れば、掛けるセルにカーソルを指定して、マクロの実行と共に同じセルに計算結果が出るようにしたいのですが・・・。
セルが決まっていれば、Range("A1").select のようにセル番地を指定出来ると思うのですが、計算したいセルが散らばってあり、尚且つカーソルで指定したセルのみを計算したい場合はどのようにコードを組めばよいのでしょうか？　分かりづらくて申し訳ありませんが、宜しくお願い致します。

回答No.3

noname#140971

エクセルは日頃は一度も操作したことはない門外漢ですので外している可能性も・・・。
まあ、参考程度にされて下さい。

次は、左ダブルクリックで0.87を乗じ、右ダブルクリックで元に戻すサンプルコードです。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
　　Dim NewValue As Currency

　　NewValue = Target.Value * CCur(0.87)
　　Target = Rounds(NewValue, 1)
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
　　Dim NewValue As Currency

　　NewValue = Target.Value * (CCur(1) / CCur(0.87))
　　Target = Rounds(NewValue, 2)
End Sub

＜標準モジュール＞
'
' Rounds関数用
'
Public Const 四捨五入 = 0
Public Const 切り捨て = 1
Public Const 切り上げ = 2

Public Function Rounds(ByVal M As Currency, _
　　　　　　　　　　　 ByVal A As Integer, _
　　　　　　　　　　　 Optional D As Integer = 0) As Variant
　　　　Rounds = Sgn(M) * Fix(Abs(M) * 10 ^ D + Abs((A = 0) * 0.5@ + (A = 2) * (Int(M * 10 ^ D) <> (M * 10 ^ D)))) / 10 ^ D
End Function

１０００
２０００
３０００

870<--左ダブルクリック
1740
2610

756<--左ダブルクリック
1513
2270

869<--右ダブルクリック
1740
2610

999<--右ダブルクリック
2000
3000

どうも、切捨て結果を元に戻すのは至難なようです。
この問題をどのように解決しますかね！

なお、Application.WorksheetFunction.RoundDown　の存在は今知りました。
余り、その使い方が判らないので　Rounds関数を用いています。
これは、Application.WorksheetFunction.RoundDown 等に置き換えられたがいいです。

お礼

回答ありがとうございました。参考にさせていただきます。勉強になりました。

回答No.2

okormazd

マクロを実行させるにはどうしますか。
コマンドボタンにしますか。

１つ１つ実行するのですか。

１つだけならとりあえず下記ですが。

Sub test()
Selection = Selection * 0.87
End Sub

お礼

回答ありがとうございました。selectionですね。参考にさせていただきます。

回答No.1

merlionXX

カーソルで指定したセルのみでしたら、Selectionで限定できます。
以下はSelectされたセルが数値であった場合に0.87を乗じて小数点以下を切り捨てます。

Sub test01()
For Each c In Selection
If c.Value <> "" And IsNumeric(c.Value) Then
c.Value = Application.WorksheetFunction.RoundDown(c.Value * 0.87, 0)
End If
Next
End Sub

お礼

回答ありがとうございました。スムーズに動作しました！是非参考にさせていただきます。