プロが教えるわが家の防犯対策術!

参考資料から転記して利用をしています、限られたことはできるのですが、希望のことが出来ません、お知恵を貸してください。

  M10 N10 O10 P10 Q10 R10 各60行までリスト表があります
  品名 単価 品名 単価 品名 単価

1、Wクリックで品名をクリックしたとき品名と単価を指定セルへ 転記先A10(品名)C10(単価)
  A30までの行間へ順次転記
2、M、O列はA10~A30の行間へ転記
3、Q列はA35~A49の行間へ転記

' // シートモジュール
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim rSrc As Range
Dim rDst As Range
Dim r As Range
' // マスタ範囲定義
Set rSrc = Me.Range("M10:R50")
' // 転記先範囲定義
Set rDst = Me.Range("A10:A49")

' // Dblクリックされたセルがマスタの範囲か?
If Not Intersect(Target, rSrc) Is Nothing Then
' // 転記先が既に埋まってないか?
If Application.CountA(rDst) = rDst.Cells.Count Then
' // 埋まっている場合
MsgBox "もう書けないっぽい", vbInformation
Else
' // (1)とりあえず転記先範囲の先頭セルを転記先に仮設定
Set r = rDst.Cells(1)
' // (2)その他空きセルを探す(空きセルのうち最初のセル)
' // 見つからない場合は、(1)が採用される
On Error Resume Next
Set r = rDst.SpecialCells(xlCellTypeBlanks).Cells(1)
On Error GoTo 0
' // 転記実行
r.Value = Target.Value
End If
' // Dblクリックで編集モードになるのをキャンセル
Cancel = True
End If
' // 後始末
Set rSrc = Nothing
Set rDst = Nothing

End Sub

少しの改良はできますが、込み合ってくると、全然改良できません
よいお知恵をください、お願いいたします。

A 回答 (2件)

#1の回答者です。



もしかして、コードの中で、

  LstRw = 35 ' ←ここでは?
   ↓
  LstRw = 31 '修正したらどうでしょう。

A列31から34行までについては、まったく空だと思っていましたが、そんなことはあるわけないですよね。気が付きませんでした。
でも、ダメだったら、全部書き換えます。
    • good
    • 0
この回答へのお礼

ご返事遅れました、テストの結果最高でした、ありがとうございました。
これで作業が軽減されます、大変ありがたく使用します。
これから、細かく検討して何が変われば、どのように記述すれば、勉強してみます。
また、ご教授お願いいたします。

お礼日時:2017/04/11 18:34

こんにちは。



なかなか、これは難しいですね。
質問のコードを見当し、それを見本にして、一応、書いてみました。

>If Not Intersect(Target, rSrc) Is Nothing Then
これは、誤動作しますので、列番号で決めたほうがよいです。

>2、M、O列はA10~A30の行間へ転記
>3、Q列はA35~A49の行間へ転記

これは、それぞれの範囲が決められているので、それぞれの範囲の空きセルを調べなくてはなりません。

>Set r = rDst.SpecialCells(xlCellTypeBlanks).Cells(1)
空いている所を探す方法よりも、上から下に付け足していく方法を考えました。
そのようにしか考えられませんでした。

ただ一つ、直せないのは、ダブルクリックで、枠線に掛かると、ジャンプが起こることがあるという現象があります。これは、やむを得ません。

以上を元にして試しに書いてみました。

'//
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 Dim rSrc As Range: Set rSrc = Range("M10:R50")
 Dim r As Range
 Dim rw As Long, LstRw As Long
 Dim rDst1 As Range: Set rDst1 = Range("A10:A30")
 Dim rDst2 As Range: Set rDst2 = Range("A35:A49")
 Dim tmpDst As Range

 If Intersect(Target, Range("M10:R50")) Is Nothing Then Exit Sub
 '条件によって変数の中身が変わる
 If Target.Column = 13 Or Target.Column = 15 Then
  Set tmpDst = rDst1
  LstRw = 35
 ElseIf Target.Column = 17 Then
  Set tmpDst = rDst2
  LstRw = 50
 Else
  GoTo Endline
 End If
 '実行
 If Application.CountA(tmpDst) = 0 Then
  Set r = tmpDst.Cells(1)
 Else
  If Application.CountA(tmpDst) < tmpDst.Cells.Count Then
    Set r = Cells(LstRw, 1).End(xlUp).Offset(1)
  Else
    MsgBox "もう書けないっぽい", vbExclamation
    GoTo Endline
  End If
 End If
 Target.Copy r
 Target.Offset(, 1).Copy r.Offset(, 2)
Endline:
 Cancel = True
 Set rSrc = Nothing
 Set rDst1 = Nothing
 Set rDst2 = Nothing
End Sub
    • good
    • 0
この回答へのお礼

ありがとうございます。
コピーして試してみました、Q列はA35~A49の行間へ転記は完璧です
M、O列はA10~A30の行間へ転記 はA10一行に転記できますがA2以後は転記しないのですが、何か変えるところか、付記しないといけませんか?
ご指導ください。

お礼日時:2017/04/11 14:16

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています