ここから本文です

前に教えてもらったマクロの何ですが、

kai********さん

2019/4/2223:00:08

前に教えてもらったマクロの何ですが、

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("V4:AO28")
' // 転記先範囲定義
Set rDst = Me.Range("AQ5:AT5,AQ6:AT6")

' // 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

複数の範囲を指定したい場合、
マスタ範囲定義 Set rSrc = Me.Range("V4:AO28")の所を
1 B4:AB22
2 B27:AB45
3 B50:AB68
4 B73:AB91
5 B96:AB114
6 B119:AB137
7 B142:AB160
8 B165:AB183
9 B188:AB206
10 B211:AB229
11 B234:AB252
12 B257:AB275
転記先範囲定義Set rDst = Me.Range("AQ5:AT5,AQ6:AT6")の所を
1 AE5:AH5、AE6:AH6
2 AE28:AH28、AE29:AH29
3 AE52:AH52、AE53:AH53
4 AE75:AH75、AE76:AH76
5 AE98:AH98、AE99:AH99
6 AE121:AH121、AE122:AH122
7 AE144:AH144、AE145:AH145
8 AE167:AH167、AE168:AH168
9 AE190:AH190、AE191:AH191
10 AE213:AH213、AE214:AH214
11 AE236:AH236、AE237:AH237
12 AE259:AH259、AE260:AH260
と複数設定(12個)したい場合どう直せばいいでしょうか?

閲覧数:
44
回答数:
1
お礼:
100枚

違反報告

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

kik********さん

2019/4/2308:22:27

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

現状4つですが、対応表ッポイ情報を vC に作っておいて・・・

※ AE ~ AH は、式ではなく値が入っている前提で・・・

>      With Range(v(k + 1))
>         .Value = .Value

と1度、値を設定し直してるので・・・
なぜか・・・は、まっさらなシートに以下を記述し、B4 に文字列設定後、
B4 をダブルクリックしてみれば・・・・
使用領域が AE, AH まで広がっていないので、空欄は無い・・・となってしまう



Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   Dim rng As Range
   Dim vC As Variant, v As Variant
   Dim k As Long

   vC = Array( _
         Array("B4:AB22", "AE5:AH6"), Array("B27:AB45", "AE28:AH29"), _
         Array("B50:AB68", "AE52:AH53"), Array("B73:AB91", "AE75:AH76") _
      )
   k = LBound(vC)

   If (Target.Value = "") Then Exit Sub
   For Each v In vC
      If (Not Intersect(Target, Range(v(k))) Is Nothing) Then Exit For
   Next
   If (IsArray(v)) Then
      On Error Resume Next
      With Range(v(k + 1))
         .Value = .Value
         Set rng = .SpecialCells(xlCellTypeBlanks)(1)
      End With
      On Error GoTo 0
      If (rng Is Nothing) Then
         MsgBox "もう書けない", vbInformation
      Else
         rng.Value = Target.Value
         Cancel = True
      End If
   End If
End Sub

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

2019/4/23 14:10:37

大変助かりました、有難うございました。

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

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

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

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

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

閉じる

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

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

閉じる