ここから本文です

VBAより 現状のダブルクリックアクションに機能を追加したいと考えており、 以下...

luc********さん

2016/11/2513:31:22

VBAより
現状のダブルクリックアクションに機能を追加したいと考えており、
以下のプログラムに補足出来るかご教示願います。

*** 現状のダブルクリックアクション(開始点) ***

' Wクリックでセルを着色
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Const Hani = "R10:V10000"
Const Iro As Variant = 6
Dim rng As Range
Set rng = Intersect(Range(Hani), Target)
If Not rng Is Nothing Then
Cancel = True
If rng.Interior.ColorIndex = xlNone Then
Range("R" & Target.Row & ":V" & Target.Row).Interior.ColorIndex = xlNone
rng.Interior.ColorIndex = Iro
Else
If rng.Interior.ColorIndex = Iro Then rng.Interior.ColorIndex = xlNone
End If
End If

' ○を入力するアクション
If Intersect(Target, Range("G6:G10000")) Is Nothing Then Exit Sub
With Target
Select Case .Value
Case ""
.Value = "○"
Case "○"
.Value = ""
End Select
End With

End Sub

*** ダブルクリックアクション (終了点) ***



【以下、補足したい機能です。(現在はクリックアクションで機能させて使用しています)】

欲しい機能の例:
現在「R1:T1」のセルに任意の数字が入っており、いずれかの数字をダブルクリックすると、
「M1」のセルに出力されるプログラムを考えています。
同様に「R2:T2」ならば「M2」にというイメージで、同一行のセルを対象としています。

***現在のプログラム***

On Error Resume Next ' エラーを無視する

'------------------------------------------------------------------
' 最終行No.取得
'------------------------------------------------------------------

'「行番号(一意の連番)」列でセル"H6"以降の値(数式含む)のある最終行No.
LastRow = Range("H6").End(xlDown).Row

'------------------------------------------------------------------
' 「単価」入力欄(範囲)のセルが選択された時、「見積単価」欄に反映
'------------------------------------------------------------------

'【重要】単価表の行の変更・削除したとき、セル範囲の変更が必要
'範囲1:"R7:T21" -----机
'範囲2:"R24:T34" -----椅子
'範囲3:"R36:T49" -----文房具
'範囲4:"R52:T80" -----雑貨
'範囲5:"R82:T416" -----粗品・景品
'範囲6:"R:T" -----

KenzaiLastRow = Range("H6").End(xlDown).Row

Set Rng1 = Range("R7:V2000")
Set Rng2 = Range("R24:V36")
Set Rng3 = Range("R36:V52")
Set Rng4 = Range("R52:V80")
Set Rng5 = Range("R1084:V" & KenzaiLastRow)

' Set Rng1 = Range("R7:V21")
'Set Rng2 = Range("R24:V34")
'Set Rng3 = Range("R36:V49")
'Set Rng4 = Range("R52:V80")
'Set Rng5 = Range("R1084:V" & KenzaiLastRow)
' Set Rng6 = Range()
'
'------------------------------------------------------------------
' 複数の「単価」入力欄を1つに結合
'------------------------------------------------------------------
'複数セル範囲を1つの大きなセル範囲の集合する
Set MyRanges = Union(Rng1, Rng2, Rng3, Rng4, Rng5)


If Intersect(Target, MyRanges) Is Nothing Then
' このセル範囲で、セルが選択されていなければ、

Exit Sub ' マクロ終了
Else ' そうでなければ(範囲内のセルが選択された時)

ACRow = ActiveCell.Row ' 選択されたセルの行No.を変数「ACRow」に代入

Range("M" & ACRow).Value = ActiveCell.Value
' 同行「見積単価」欄に選択されたセル値を代入
End If
以上ですが、どうぞよろしくお願いいたします。

閲覧数:
97
回答数:
2
お礼:
100枚

違反報告

ベストアンサーに選ばれた回答

kik********さん

2016/11/2514:59:47

雰囲気以下でどうなりますか


Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   Dim vC As Variant, v As Variant
   Const CCR As Long = 6

   vC = Array( _
         Array(1, "R:V", "10:" & Rows.Count), _
         Array(2, "G:G", "6:" & Rows.Count), _
         Array(3, "R:T", "1:" & Rows.Count) _
      )
   For Each v In vC
      If (Not Intersect(Target, Me.UsedRange, Range(v(1)), Range(v(2))) _
         Is Nothing) Then
         Cancel = True
         Application.EnableEvents = False
         Select Case v(0)
            Case 1
               With Intersect(Target.EntireRow, Range(v(1)))
                  If (Target.Interior.ColorIndex = xlNone) Then
                     .Interior.ColorIndex = xlNone
                     Target.Interior.ColorIndex = CCR
                  ElseIf (Target.Interior.ColorIndex = CCR) Then
                     Target.Interior.ColorIndex = xlNone
                  End If
               End With
            Case 2
               With Target
                  Select Case .Value
                     Case "": .Value = "○"
                     Case "○": .Value = ""
                  End Select
               End With
            Case 3
               With Target
                  .Offset(, Range("M1").Column - .Column).Value = .Value
               End With
         End Select
         Application.EnableEvents = True
      End If
   Next
End Sub

質問した人からのコメント

2016/11/25 17:40:59

kiku30246様
早々のご回答ありがとうございます。

ご教示頂いた内容で求めていた動作を得ることが出来ました。
誠にありがとうございました。

ベストアンサー以外の回答

1〜1件/1件中

プロフィール画像

カテゴリマスター

ina********さん

2016/11/2514:43:05

一つのイベントプロシージャの中で複数の事を行おうとすると、
プログラムがどんどん長くなり、読みにくく保守しずらい
プログラムになってしまいます。

(これは、イベントプロシージャに限ったことではありませんが。)

そういう場合は、機能毎に別プロシージャにして、メインプロシージャ
から各々のプロシージャを実行(コール)するようにすると良いです。


直接的な、質問に対する回答コードではありませんが、

「機能毎に別プロシージャに」が理解しやすいように簡単なサンプル
を書くと以下のようになります。
(イメージコードですのでコピペしても動きません、ご注意。)


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
ProcA Target, Cancel
ProcB Target, Cancel
ProcC Target, Cancel
End Sub


Private Sub ProcA(ByVal Target As Range, Cancel As Boolean)
If Not 処理対象範囲 Then Exit Sub
Cancel = True
Application.EnableEvents = False '次の処理でセル値を書き換える時必要、書き換えが無いなら不要
処理
Application.EnableEvents = True
End Sub


Private Sub ProcB(ByVal Target As Range, Cancel As Boolean)
同上
End Sub


Private Sub ProcC(ByVal Target As Range, Cancel As Boolean)
同上
End Sub



実際に回答した例が下記にあります。

http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1416690144...

あわせて知りたい

この質問につけられたタグ

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる